pcvr coverage - 81.42%

Files
Source

#' subset helper function for use reading in large data, called in pcv.sub.read
#'
#'
#'
#' @param inputFile Path to csv file of plantCV output, should be provided internally in read.pcv
#' @param filters filtering conditions, see read.pcv for details. Format as
#' list("trait in area, perimeter", "other contains stringToMatch")
#' @param awk Optional awk command to use instead.
#' @keywords read.csv pcv wide long
#' @details awkHelper attempts to make awk commands from human readable input.
#' Currently when filters are supplied the input file has quotes removed by `sed`
#' then is piped into awk, so an equivalent command line statement may be:
#' \code{sed 's/\"//g' pcvrTest2.csv | awk -F ','  '{ if (NR==1 || $18=="area") { print } }'}
#' @return Returns a character string representing a unix style awk statement
#'   which is typically passed to \code{pipe} or used as a connection in \code{data.table::fread}.
#' @importFrom utils read.csv capture.output
#' @examples
#' link1 <- "https://gist.githubusercontent.com/seankross/"
#' link2 <- "a412dfbd88b3db70b74b/raw/5f23f993cd87c283ce766e7ac6b329ee7cc2e1d1/mtcars.csv"
#' file <- paste0(link1, link2)
#' awkHelper(file, list("gear in 4, 3"), awk = NULL)
#' awkHelper(file, "gear contains 3", awk = NULL)
#' # note that to be filtered the file has to exist on your local system, this example is only to show
#' # the output of awkHelper, which would then be executed by read.pcv
#' awkHelper(file, list("gear in 4, 3"), awk = "existing_command")
#'
#' @export
awkHelper <- function(inputFile, filters, awk = NULL) {
  if (is.null(awk)) {
    if (!is.list(filters)) {
      filters <- list(filters)
    }
    sed <- paste0("sed 's/\"//g' ", inputFile, " | ")
    awkStart <- "awk -F "
    awkDelim <- "',' "
    awkFiltStart <- "'{ if ("
    awkFiltEnd <- ") { print } }'"
    COLS <- colnames(read.csv(inputFile, nrows = 1))
    awkFilts <- lapply(filters, function(filt) {
      filtCol <- strsplit(filt, " ")[[1]][1]
      affector <- strsplit(filt, " ")[[1]][2]
      values <- trimws(gsub(",", " ", strsplit(filt, " ")[[1]][-c(1:2)]))
      if (affector %in% c("in", "is", "=")) {
        paste(paste0("($", which(COLS == filtCol), '=="', values, '")'), collapse = " || ")
      } else if (affector == "contains") {
        valReg <- paste0(values, collapse = "|")
        paste0("($", which(COLS == filtCol), " ~ /", valReg, "/)")
      }
    })
    awkFilt <- paste(paste("(", awkFilts, ")"), collapse = " && ")
    awkCommand <- capture.output(cat(sed, awkStart, awkDelim, awkFiltStart, awkFilt, awkFiltEnd))
  } else {
    awkCommand <- awk
  }
  return(awkCommand)
}

#' @description
#' Internal function for calculating \mu and \sigma of the normally distributed mean of lognormal data
#' given an estimate of the lognormal \sigma obtained via the method of moments using multi value
#' traits.
#' @param s1 A data.frame or matrix of multi value traits. The column names should include a number
#' representing the "bin".
#'
#' @examples
#'
#' mv_ln <- mvSim(
#'   dists = list(
#'     rlnorm = list(meanlog = log(130), sdlog = log(1.2))
#'   ),
#'   n_samples = 30
#' )
#' .conj_lognormal_mv(
#'   s1 = mv_ln[1:30, -1],
#'   priors = list(mu_log = c(log(10)), n = c(1), sigma_log = c(log(3))),
#'   plot = FALSE, cred.int.level = 0.9
#' )
#'
#' @importFrom stats qnorm
#' @keywords internal
#' @noRd

.conj_lognormal_mv <- function(s1 = NULL, priors = NULL,
                               plot = FALSE, support = NULL, cred.int.level = NULL,
                               calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(mu = 0, sd = 5)
  }
  #* `Reorder columns if they are not in the numeric order`
  histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
  bins_order <- sort(histColsBin, index.return = TRUE)$ix
  s1 <- s1[, bins_order]

  #* `Loop over reps, get moments for each histogram`

  rep_distributions <- lapply(seq_len(nrow(s1)), function(i) {
    X1 <- rep(histColsBin[bins_order], as.numeric(s1[i, ]))
    #* `Get mean of X1`
    x_bar <- mean(X1)
    mu_x1 <- log(x_bar / (sqrt(var(X1) / x_bar^2) + 1))
    #* `Get sigma of X1`
    sigma_x1 <- sqrt(log((var(X1)) / (x_bar^2) + 1))
    #* `Update Normal Distribution of Mu`
    #* sufficient stats: n, mean of log data | precision
    n <- length(X1)
    m <- priors$mu[1]
    p <- 1 / (priors$sd[1]^2) # precision
    mu_prime <- ((m * p) + (n * p * mu_x1)) / (p + (n * p))
    precision_prime <- (p + (n * p))
    var_prime <- 1 / precision_prime
    sd_prime <- sqrt(var_prime)
    return(list("mu" = mu_prime, "sd" = sd_prime, "ln_sd" = sigma_x1))
  })
  #* `Unlist parameters`
  mu_ls_prime <- mean(unlist(lapply(rep_distributions, function(i) {
    i$mu
  })))
  sigma_ls_prime <- mean(unlist(lapply(rep_distributions, function(i) {
    i$sd
  })))
  ln_sigma_prime <- mean(unlist(lapply(rep_distributions, function(i) {
    i$ln_sd
  })))

  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- stats::qnorm(c(0.0001, 0.9999), mu_ls_prime, sigma_ls_prime)
    return(quantiles)
  }
  #* `posterior`
  dens1 <- stats::dnorm(support, mu_ls_prime, sigma_ls_prime)
  pdf1 <- dens1 / sum(dens1)
  hde1 <- mu_ls_prime
  hdi1 <- stats::qnorm(
    c(
      (1 - cred.int.level) / 2,
      (1 - ((1 - cred.int.level) / 2))
    ),
    mu_ls_prime, sigma_ls_prime
  )
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior$mu <- mu_ls_prime
  out$posterior$sd <- sigma_ls_prime
  out$posterior$lognormal_sigma <- ln_sigma_prime
  #* `Make Posterior Draws`
  out$posteriorDraws <- stats::rnorm(10000, mu_ls_prime, sigma_ls_prime)
  out$pdf <- pdf1
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}



#' @description
#' Internal function for calculating \mu and \sigma of the normally distributed mean of lognormal data
#' given an estimate of the lognormal \sigma obtained via the method of moments using single value
#' traits.
#'
#' @param s1 A vector of numerics drawn from a gaussian distribution.
#' @examples
#' .conj_lognormal_sv(
#'   s1 = rlnorm(100, log(130), log(1.3)),
#'   priors = list(mu = 5, sd = 5),
#'   plot = FALSE,
#'   cred.int.level = 0.89
#' )
#' @keywords internal
#' @noRd

.conj_lognormal_sv <- function(s1 = NULL, priors = NULL,
                               plot = FALSE, support = NULL, cred.int.level = NULL,
                               calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(mu = 0, sd = 5)
  }
  #* `Get mean of s1`
  x_bar <- mean(s1)
  mu_s1 <- log(x_bar / (sqrt(var(s1) / x_bar^2) + 1))
  #* `Get sigma of s1`
  sigma_s1 <- sqrt(log((var(s1)) / (x_bar^2) + 1))
  #* `Update Normal Distribution of Mu`
  #* sufficient stats: n, mean of log data | precision
  n <- length(s1)
  m <- priors$mu[1]
  p <- 1 / (priors$sd[1]^2) # precision
  mu_prime <- ((m * p) + (n * p * mu_s1)) / (p + (n * p))
  precision_prime <- (p + (n * p))
  var_prime <- 1 / precision_prime
  sd_prime <- sqrt(var_prime)
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- stats::qnorm(c(0.0001, 0.9999), mu_prime, sd_prime)
    return(quantiles)
  }
  #* `posterior`
  dens1 <- dnorm(support, mu_prime, sd_prime)
  pdf1 <- dens1 / sum(dens1)
  hde1 <- mu_prime
  hdi1 <- qnorm(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), mu_prime, sd_prime)
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior$mu <- mu_prime
  out$posterior$sd <- sd_prime
  out$posterior$lognormal_sigma <- sigma_s1 # returning this as a number, not a distribution
  #* `Make Posterior Draws`
  out$posteriorDraws <- rnorm(10000, mu_prime, sd_prime)
  out$pdf <- pdf1
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' @description
#' Internal function for calculating the pareto distribution of the upper boundary of a uniform
#' distribution represented by single value traits.
#' @param s1 A vector of numerics drawn from a uniform distribution.
#' @examples
#' out <- .conj_bivariate_lognormal_sv(
#'   s1 = rlnorm(10, log(20), 1), cred.int.level = 0.95,
#'   plot = FALSE
#' )
#' lapply(out, head)
#'
#' @keywords internal
#' @noRd

.conj_bivariate_lognormal_sv <- function(s1 = NULL, priors = NULL,
                                         plot = FALSE, support = NULL, cred.int.level = NULL,
                                         calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  #* conjugate prior needs alpha, beta, mu, prec (or var or sd)
  #* precision is Gamma(alpha, beta)
  #* mu is T_[2*alpha](mu, precision)
  if (is.null(priors)) {
    priors <- list(mu = 0, sd = 10, a = 1, b = 1)
  }
  #* `Extract prior components`
  alpha <- priors$a[1]
  beta <- priors$b[1]
  mu <- priors$mu[1]
  prec <- 1 / (priors$sd^2)
  #* `Calculate sufficient statistics`
  n <- length(s1)
  x_bar <- mean(log(s1))
  ss <- sum((s1 - x_bar)^2)
  #* `Update priors with sufficient statistics`
  alpha_prime <- alpha + (n / 2)
  beta_prime <- 1 / ((1 / beta) + (ss / 2) + ((prec * n * ((x_bar - mu)^2)) / (2 * (prec + n))))
  mu_prime <- ((prec * mu) + (n * x_bar)) / (prec + n)
  prec_prime <- prec + n
  df_prime <- 2 * alpha_prime
  prec_prime_t <- alpha_prime * prec_prime * beta_prime
  sigma_prime <- sqrt(1 / prec_prime_t)
  #* `Define bivariate support if it is missing`
  if (is.null(support)) {
    quantiles_mu <- extraDistr::qlst(c(0.0001, 0.9999), df_prime, mu_prime, sigma_prime)
    quantiles_prec <- stats::qgamma(c(0.0001, 0.9999), shape = alpha_prime, scale = beta_prime)
    support_mu <- seq(quantiles_mu[1], quantiles_mu[2], length.out = 10000)
    support_prec <- seq(quantiles_prec[1], quantiles_prec[2], length.out = 10000)
    if (calculatingSupport) {
      return(list("Mu" = quantiles_mu, "Prec" = quantiles_prec))
    }
  } else {
    support_mu <- support$Mu
    support_prec <- support$Prec
  }
  #* `Make Posterior Draws`
  out$posteriorDraws <- .conj_biv_rough_sampling(
    10000, alpha_prime, beta_prime,
    mu_prime, sigma_prime, df_prime
  )
  #* `posterior`
  dens_mu <- extraDistr::dlst(support_mu, df_prime, mu_prime, sigma_prime)
  dens_prec <- stats::dgamma(support_prec, shape = alpha_prime, scale = beta_prime)

  pdf_mu <- dens_mu / sum(dens_mu)
  pdf_prec <- dens_prec / sum(dens_prec)
  out$pdf <- list("Mu" = pdf_mu, "Prec" = pdf_prec)

  hde_mu <- mu_prime
  hde_prec <- .gammaHDE(shape = alpha_prime, scale = beta_prime)
  hdi_mu <- -1 * rev(extraDistr::qlst(
    c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    df_prime, mu_prime, sigma_prime
  ))
  hdi_prec <- -1 * rev(stats::qgamma(
    c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    shape = alpha_prime, scale = beta_prime
  ))

  #* `Store summary`
  out$summary <- data.frame(
    HDE_1 = c(hde_mu, hde_prec),
    HDI_1_low = c(hdi_mu[1], hdi_prec[1]),
    HDI_1_high = c(hdi_mu[2], hdi_prec[2]),
    param = c("Mu", "Prec")
  )
  out$posterior <- list(
    "mu" = mu_prime, "sd" = sigma_prime,
    "a" = alpha_prime, "b" = beta_prime
  )
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = c(support_mu, support_prec),
      "prob" = c(pdf_mu, pdf_prec),
      "param" = rep(c("Mu", "Prec"), each = length(support_mu)),
      "sample" = rep("Sample 1", 2 * length(support_mu))
    )
  }
  return(out)
}

#' Helper function for visualizing differences in GAMs fit with \code{mgcv::gam}
#'
#' Note that using GAMs will be less useful than fitting parameterized models as supported by
#' \code{growthSS} and \code{fitGrowth} for common applications in plant phenotyping.
#'
#' @param model A model fit with smooth terms by \code{mgcv::gam}
#' @param newdata A data.frame of new data to use to make predictions. If this is left NULL
#' (the default) then
#' an attempt is made to make newdata using the first smooth term in the formula.
#' See examples for guidance on making appropriate newdata
#' @param g1 A character string for the level of byVar to use as the first group to compare,
#' if plot=TRUE then this will be shown in blue.
#' @param g2 The second group to compare (comparison will be g1 - g2). If plot=TRUE then this will be
#' shown in red.
#' @param byVar Categorical variable name used to separate splines as a string.
#' @param smoothVar The variable that splines were used on. This will often be a time variable.
#' @param cis Confidence interval levels, can be multiple. For example, 0.95 would return Q_0.025 and
#' Q_0.975 columns, and c(0.9, 0.95) would return Q_0.025, Q_0.05, Q_0.95, and Q_0.975 columns.
#' Defaults to \code{seq(0.05, 0.95, 0.05)}
#' @param unconditional Logical, should unconditional variance-covariance be used in calculating
#' standard errors. Defaults to TRUE.
#' @param plot Logical, should a plot of the difference be returned? Defaults to TRUE.
#'
#' @keywords gam
#' @importFrom mgcv gam s
#' @importFrom stats vcov predict df.residual qt
#' @importFrom viridis viridis
#' @import ggplot2
#' @import patchwork
#' @return A dataframe or a list containing a ggplot and a dataframe
#' @examples
#'
#' ex <- pcvr::growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list(
#'     "A" = c(200, 160),
#'     "B" = c(13, 11),
#'     "C" = c(3, 3.5)
#'   )
#' )
#'
#' m <- mgcv::gam(y ~ group + s(time, by = factor(group)), data = ex)
#'
#' support <- expand.grid(
#'   time = seq(min(ex$time), max(ex$time), length = 400),
#'   group = factor(unique(ex$group))
#' )
#'
#' out <- gam_diff(
#'   model = m, newdata = support, g1 = "a", g2 = "b",
#'   byVar = "group", smoothVar = "time", plot = TRUE
#' )
#' dim(out$data)
#' out$plot
#' out2 <- gam_diff(
#'   model = m, g1 = "a", g2 = "b", byVar = NULL, smoothVar = NULL, plot = TRUE
#' )
#' @export

gam_diff <- function(model, newdata = NULL, g1, g2, byVar = NULL, smoothVar = NULL,
                     cis = seq(0.05, 0.95, 0.05), unconditional = TRUE, plot = TRUE) {
  form <- model$formula
  rhs <- as.character(form)[3]
  rg <- regexpr("s\\([a-zA-Z0-9.]+", rhs)
  xTerm <- sub("s\\(", "", regmatches(rhs, rg)[1])
  rg2 <- regexpr("by\\s?=\\s?.*[a-zA-Z0-9.]+", rhs)
  byTerm <- sub(".*\\(", "", sub("by\\s?=\\s?", "", regmatches(rhs, rg2)[1]))
  mdf <- model$model

  if (is.null(newdata)) {
    newdata <- expand.grid(
      x = seq(min(mdf[[xTerm]]), max(mdf[[xTerm]]),
        length.out = round(diff(range(mdf[[xTerm]])) * 500)
      ),
      g = factor(unique(mdf[[byTerm]]))
    )
    colnames(newdata) <- c(xTerm, byTerm)
  }
  if (is.null(byVar)) {
    byVar <- byTerm
  }
  if (is.null(smoothVar)) {
    smoothVar <- xTerm
  }

  xp <- stats::predict(model, newdata = newdata, type = "lpmatrix")
  c1 <- grepl(g1, colnames(xp))
  c2 <- grepl(g2, colnames(xp))
  r1 <- newdata[[byVar]] == g1
  r2 <- newdata[[byVar]] == g2
  ## difference rows of xp for data from comparison
  X <- xp[r1, ] - xp[r2, ]
  ## zero out cols of X related to splines for other lochs
  X[, !(c1 | c2)] <- 0
  ## zero out the parametric cols
  X[, !grepl("^s\\(", colnames(xp))] <- 0
  dif <- X %*% coef(model)
  se <- sqrt(rowSums((X %*% stats::vcov(model, unconditional = unconditional)) * X))
  df.resid <- stats::df.residual(model)

  cis_diff_df <- do.call(cbind, lapply(cis, function(ci) {
    crit <- stats::qt(1 - ((1 - ci) / 2), df.resid, lower.tail = TRUE)
    upr <- dif + (crit * se)
    lwr <- dif - (crit * se)
    setNames(data.frame(upr, lwr), paste0(
      c("Q_diff_", "Q_diff_"),
      round(c(1 - ((1 - ci) / 2), 1 - (1 - ((1 - ci) / 2))), 3)
    ))
  }))
  cis_diff_df <- cis_diff_df[, order(colnames(cis_diff_df))]

  out_df <- cbind(data.frame(g1 = g1, g2 = g2, mu = dif, se = se), cis_diff_df)
  if (plot) {
    #* `g1 model CIs`
    x_g1 <- xp[r1, ]
    ## keep only relevant splines and intercept term
    c1_g1 <- grepl(g1, colnames(xp)) | grepl("\\(Intercept\\)", colnames(xp))
    x_g1[, !(c1_g1)] <- 0
    ## zero out the parametric cols
    x_g1[, !grepl("\\(Intercept\\)|^s\\(", colnames(xp))] <- 0
    g1_vals <- x_g1 %*% coef(model)
    se_g1 <- sqrt(rowSums((x_g1 %*% stats::vcov(model, unconditional = unconditional)) * x_g1))
    cis_g1_df <- do.call(cbind, lapply(cis, function(ci) {
      crit <- stats::qt(1 - ((1 - ci) / 2), df.resid, lower.tail = TRUE)
      upr <- g1_vals + (crit * se_g1)
      lwr <- g1_vals - (crit * se_g1)
      setNames(data.frame(upr, lwr), paste0(
        c("Q_g1_", "Q_g1_"),
        round(c(1 - ((1 - ci) / 2), 1 - (1 - ((1 - ci) / 2))), 3)
      ))
    }))
    cis_g1_df <- cis_g1_df[, order(colnames(cis_g1_df))]
    #* `g2 model CIs`
    x_g2 <- xp[r2, ]
    ## keep only relevant splines and intercept term
    c2_g2 <- grepl(g2, colnames(xp)) | grepl("\\(Intercept\\)", colnames(xp))
    x_g2[, !(c2_g2)] <- 0
    ## zero out the parametric cols
    x_g2[, !grepl("\\(Intercept\\)|^s\\(", colnames(xp))] <- 0
    g2_vals <- x_g2 %*% coef(model)
    se_g2 <- sqrt(rowSums((x_g2 %*% stats::vcov(model, unconditional = unconditional)) * x_g2))
    cis_g2_df <- do.call(cbind, lapply(cis, function(ci) {
      crit <- stats::qt(1 - ((1 - ci) / 2), df.resid, lower.tail = TRUE)
      upr <- g2_vals + (crit * se_g2)
      lwr <- g2_vals - (crit * se_g2)
      setNames(data.frame(upr, lwr), paste0(
        c("Q_g2_", "Q_g2_"),
        round(c(1 - ((1 - ci) / 2), 1 - (1 - ((1 - ci) / 2))), 3)
      ))
    }))
    cis_g2_df <- cis_g2_df[, order(colnames(cis_g2_df))]

    out_df <- cbind(out_df, cis_g1_df, cis_g2_df)
  }

  out_df$df.resid <- df.resid

  smoothVarRange <- range(newdata[[smoothVar]], na.rm = TRUE)
  smoothVarOut <- seq(min(smoothVarRange), max(smoothVarRange), length.out = length(dif))
  out_df[[smoothVar]] <- smoothVarOut
  out <- out_df
  if (plot) {
    p_diff <- .plot_gam_diff(out_df, name_pattern = "Q_diff_") +
      ggplot2::theme(
        axis.title.x.bottom = ggplot2::element_blank(),
        axis.text.x.bottom = ggplot2::element_blank()
      )
    p_model <- .plot_gam_diff(out_df,
      name_pattern = "Q_g1_",
      name_pattern2 = "Q_g2_"
    )
    layout_obj <- patchwork::plot_layout(
      design = c(
        patchwork::area(1, 1, 4, 6),
        patchwork::area(5, 1, 6, 6)
      )
    )
    patchPlot <- p_model / p_diff + layout_obj
    out <- list("data" = out_df, "plot" = patchPlot)
  }
  return(out)
}

#' ***********************************************************************************************
#' *************** `Plot difference in smooths` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for plotting spline_diff output
#'
#' @keywords internal
#' @noRd

.plot_gam_diff <- function(df, name_pattern = "Q_diff_", name_pattern2 = NULL) {
  x <- colnames(df)[ncol(df)]
  nms <- colnames(df)
  nms <- as.numeric(sub(name_pattern, "", nms[grepl(paste0("^", name_pattern), nms)]))
  cis <- numeric()
  i <- 1
  while (length(nms) > 1) {
    cis[i] <- max(nms) - min(nms)
    nms <- nms[-which.max(nms)]
    nms <- nms[-which.min(nms)]
    i <- i + 1
  }
  cis <- rev(cis)
  virPal <- viridis::viridis(n = length(cis), option = "mako", direction = -1, begin = 0.1)

  if (is.null(name_pattern2)) {
    lineLayer <- list(
      ggplot2::geom_line(ggplot2::aes(y = .data[["mu"]])),
      ggplot2::geom_hline(yintercept = 0, linetype = 5),
      ggplot2::labs(y = paste0(df[1, "g1"], " - ", df[1, "g2"]))
    )
  } else {
    lineLayer <- ggplot2::labs(y = "Model Prediction")
  }

  splinePlot <- ggplot2::ggplot(df, aes(x = .data[[x]])) +
    lapply(rev(seq_along(cis)), function(i) {
      ci <- cis[i]
      ggplot2::geom_ribbon(
        ggplot2::aes(
          ymin = .data[[paste0(name_pattern, 1 - (1 - ((1 - ci) / 2)))]],
          ymax = .data[[paste0(name_pattern, 1 - ((1 - ci) / 2))]]
        ),
        fill = virPal[i], alpha = 0.5
      )
    }) +
    lineLayer +
    pcv_theme()

  if (!is.null(name_pattern2)) {
    virPal2 <- viridis::viridis(n = length(cis), option = "inferno", direction = -1, begin = 0.1)
    splinePlot <- splinePlot +
      lapply(rev(seq_along(cis)), function(i) {
        ci <- cis[i]
        ggplot2::geom_ribbon(
          ggplot2::aes(
            ymin = .data[[paste0(name_pattern2, 1 - (1 - ((1 - ci) / 2)))]],
            ymax = .data[[paste0(name_pattern2, 1 - ((1 - ci) / 2))]]
          ),
          fill = virPal2[i], alpha = 0.5
        )
      })
  }

  return(splinePlot)
}

#' Function to visualize brms models similar to those made using growthSS outputs.
#'
#' Models fit using \link{growthSS} inputs by \link{fitGrowth} (and similar models made through other
#' means) can be visualized easily using this function. This will generally be called by
#' \code{growthPlot}.
#'
#' @param fit A brmsfit object, similar to those fit with \code{\link{growthSS}} outputs.
#' @param form A formula similar to that in \code{growthSS} inputs specifying the outcome,
#' predictor, and grouping structure of the data as \code{outcome ~ predictor|individual/group}.
#' @param df An optional dataframe to use in plotting observed growth curves on top of the model.
#' @param groups An optional set of groups to keep in the plot.
#' Defaults to NULL in which case all groups in the model are plotted.
#' @param timeRange An optional range of times to use. This can be used to view predictions for
#' future data if the available data has not reached some point (such as asymptotic size),
#' although prediction using splines outside of the observed range is not necessarily reliable.
#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
#' @param hierarchy_value If a hierarchical model is being plotted, what value should the
#' hiearchical predictor be? If left NULL (the default) the mean value is used.
#' @param vir_option Viridis color scale to use for plotting credible intervals. Defaults to "plasma".
#' @keywords growth-curve brms
#' @import ggplot2
#' @import viridis
#' @importFrom stats as.formula
#' @examples
#' \donttest{
#' simdf <- growthSim(
#'   "logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group, sigma = "spline",
#'   list("A" = 130, "B" = 10, "C" = 3),
#'   df = simdf, type = "brms"
#' )
#' fit <- fitGrowth(ss, backend = "cmdstanr", iter = 500, chains = 1, cores = 1)
#' growthPlot(fit = fit, form = y ~ time | group, groups = "a", df = ss$df)
#' }
#'
#' @return Returns a ggplot showing a brms model's credible
#' intervals and optionally the individual growth lines.
#'
#' @export

brmPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE,
                    hierarchy_value = NULL, vir_option = "plasma") {
  fitData <- fit$data
  parsed_form <- .parsePcvrForm(form, df)
  if (!is.numeric(fitData[, parsed_form$x]) && !parsed_form$USEG && !parsed_form$USEID) {
    p <- .brmStaticPlot(fit, form, df, groups, facetGroups, vir_option, fitData, parsed_form)
    return(p)
  }
  p <- .brmLongitudinalPlot(
    fit, form, df, groups, timeRange, facetGroups,
    hierarchy_value, vir_option, fitData, parsed_form
  )
  return(p)
}

#' @keywords internal
#' @noRd
.brmStaticPlot <- function(fit, form, df = NULL, groups = NULL, facetGroups = TRUE,
                           vir_option = "plasma", fitData, parsed_form) {
  y <- parsed_form$y
  x <- parsed_form$x
  individual <- parsed_form$individual
  if (individual == "dummyIndividual") {
    individual <- NULL
  }
  group <- parsed_form$group
  df <- parsed_form$data
  probs <- seq(from = 99, to = 1, by = -2) / 100
  newData <- data.frame(
    x = unique(fitData[[x]])
  )
  colnames(newData) <- x
  predictions <- cbind(newData, predict(fit, newData, probs = probs))
  if (!is.null(groups)) {
    predictions <- predictions[predictions$group %in% groups, ]
    if (!is.null(df)) {
      df <- df[df[[group]] %in% groups, ]
    }
  }
  #* `facetGroups`
  facetLayer <- NULL
  if (facetGroups && length(unique(fitData[[group]])) > 1) {
    facetLayer <- ggplot2::facet_wrap(as.formula(paste0("~", group)))
  }
  #* `lengthen predictions`
  max_prime <- 0.99
  min_prime <- 0.01
  max_obs <- 49
  min_obs <- 1
  c1 <- (max_prime - min_prime) / (max_obs - min_obs)
  longPreds <- do.call(rbind, lapply(seq_len(nrow(predictions)), function(r) {
    sub <- predictions[r, ]
    do.call(rbind, lapply(seq(1, 49, 2), function(i) {
      min <- paste0("Q", i)
      max <- paste0("Q", 100 - i)
      iter <- sub[, c(x, "Estimate")]
      iter$q <- round(1 - (c1 * (i - max_obs) + max_prime), 2)
      iter$min <- sub[[min]]
      iter$max <- sub[[max]]
      iter
    }))
  }))
  #* `Make Numeric Groups`
  longPreds$numericGroup <- as.numeric(as.factor(longPreds[[x]]))
  #* `Make plot`
  p <- ggplot2::ggplot(longPreds, ggplot2::aes(x = .data[[x]], y = .data$Estimate)) +
    facetLayer +
    ggplot2::labs(x = x, y = y) +
    pcv_theme()
  p <- p +
    lapply(unique(longPreds$q), function(q) {
      ggplot2::geom_rect(
        data = longPreds[longPreds$q == q, ],
        ggplot2::aes(
          xmin = .data[["numericGroup"]] - c(0.45 * (1 - .data[["q"]])),
          xmax = .data[["numericGroup"]] + c(0.45 * (1 - .data[["q"]])),
          ymin = .data[["min"]],
          ymax = .data[["max"]],
          group = .data[[x]],
          fill = .data[["q"]]
        ), alpha = 0.5
      )
    }) +
    viridis::scale_fill_viridis(direction = -1, option = vir_option) +
    ggplot2::labs(fill = "Credible\nInterval")
  return(p)
}
#' @keywords internal
#' @noRd

.brmLongitudinalPlot <- function(fit, form, df = NULL, groups = NULL,
                                 timeRange = NULL, facetGroups = TRUE,
                                 hierarchy_value = NULL, vir_option = "plasma",
                                 fitData, parsed_form) {
  y <- parsed_form$y
  x <- parsed_form$x
  individual <- parsed_form$individual
  hierarchical_predictor <- parsed_form$hierarchical_predictor
  if (individual == "dummyIndividual") {
    individual <- NULL
  }
  group <- parsed_form$group
  df <- parsed_form$data
  probs <- seq(from = 99, to = 1, by = -2) / 100
  if (is.null(timeRange)) {
    timeRange <- unique(fitData[[x]])
  }
  newData <- data.frame(
    x = rep(timeRange, times = length(unique(fitData[[group]]))),
    group = rep(unique(fitData[[group]]), each = length(timeRange)),
    individual = rep(paste0("new_", seq_along(unique(fitData[[group]]))), each = length(timeRange))
  )
  colnames(newData) <- c(x, group, individual)
  if (!is.null(hierarchical_predictor)) {
    if (is.null(hierarchy_value)) {
      hierarchy_value <- mean(fitData[[hierarchical_predictor]])
    }
    newData[[hierarchical_predictor]] <- hierarchy_value
  }
  predictions <- cbind(newData, predict(fit, newData, probs = probs))

  if (!is.null(groups)) {
    predictions <- predictions[predictions$group %in% groups, ]
    if (!is.null(df)) {
      df <- df[df[[group]] %in% groups, ]
    }
  }
  #* `facetGroups`
  facetLayer <- NULL
  if (facetGroups && length(unique(fitData[[group]])) > 1) {
    facetLayer <- ggplot2::facet_wrap(as.formula(paste0("~", group)))
  }
  #* `lengthen predictions`
  max_prime <- 0.99
  min_prime <- 0.01
  max_obs <- 49
  min_obs <- 1
  c1 <- (max_prime - min_prime) / (max_obs - min_obs)
  longPreds <- do.call(rbind, lapply(seq_len(nrow(predictions)), function(r) {
    sub <- predictions[r, ]
    do.call(rbind, lapply(seq(1, 49, 2), function(i) {
      min <- paste0("Q", i)
      max <- paste0("Q", 100 - i)
      iter <- sub[, c(x, group, individual, "Estimate")]
      iter$q <- round(1 - (c1 * (i - max_obs) + max_prime), 2)
      iter$min <- sub[[min]]
      iter$max <- sub[[max]]
      iter
    }))
  }))
  #* `Make plot`
  p <- ggplot2::ggplot(longPreds, ggplot2::aes(x = .data[[x]], y = .data$Estimate)) +
    facetLayer +
    ggplot2::labs(x = x, y = y) +
    pcv_theme()
  p <- p +
    lapply(unique(longPreds$q), function(q) {
      ggplot2::geom_ribbon(
        data = longPreds[longPreds$q == q, ],
        ggplot2::aes(
          ymin = .data[["min"]],
          ymax = .data[["max"]],
          group = .data[[group]],
          fill = .data[["q"]]
        ), alpha = 0.5
      )
    }) +
    viridis::scale_fill_viridis(direction = -1, option = vir_option) +
    ggplot2::labs(fill = "Credible\nInterval")

  if (!is.null(df) && !is.null(individual)) {
    p <- p + ggplot2::geom_line(
      data = df, ggplot2::aes(.data[[x]], .data[[y]],
        group = interaction(.data[[individual]], .data[[group]])
      ),
      color = "gray20", linewidth = 0.2
    )
  }
  return(p)
}

#' Helper to make pcvr default priors from several kinds of input
#' @keywords internal
#' @noRd

.makePriors <- function(priors, pars, df, group, USEGROUP, sigma, family, formula) {
  if (is.null(priors)) {
    prior <- .explicitDefaultPrior(formula, df, family)
    return(prior)
  }
  #* `if priors is a brmsprior`
  if (any(methods::is(priors, "brmsprior"))) {
    return(priors)
  }
  #* `if priors is a numeric vector`
  priors <- .fixNumericPriors(priors, pars)
  #* `if priors is a list`
  formatListPriorsRes <- .formatListPriors(priors, pars, df, group, USEGROUP)
  priors <- formatListPriorsRes[["priors"]]
  groupedPriors <- formatListPriorsRes[["groupedPriors"]]
  #* `Arrange priors to match pars explicitly`
  if (length(setdiff(pars, names(priors))) > 0) {
    specified_pars <- intersect(names(priors), pars)
    unspecified_pars <- setdiff(pars, names(priors))
    priors <- priors[specified_pars]
    pars <- c(specified_pars, unspecified_pars)
  } else {
    priors <- priors[pars]
  }
  #* `Make stan strings`
  priorStanStrings <- .stanStringHelper(priors, pars, USEGROUP)
  #* `get default priors for intercept only distributional parameters`
  prior <- .initializePriorObject(sigma, family)
  #* `add priors for estimated parameters`
  for (nm in names(priorStanStrings)) {
    dist <- priorStanStrings[[nm]]
    pr <- strsplit(nm, "_")[[1]][1]
    if (USEGROUP && groupedPriors) { # if there are groups and they have different priors
      gr <- paste0(group, strsplit(nm, "_")[[1]][2])
      prior <- prior + brms::set_prior(dist, coef = gr, nlpar = pr)
      # currently cannot set lb for prior with coef
      # there is a clunky workaround but it wouldn't work with expected data types
      # https://github.com/paul-buerkner/brms/issues/86
    } else {
      lb <- ifelse(grepl("changePoint|I$", pr), NA, 0)
      prior <- prior + brms::set_prior(dist, nlpar = pr, lb = lb)
    }
  }
  prior <- prior[-1, ] # remove flat prior on b
  prior <- unique(prior)
  # could add intercept term prior here
  return(prior)
}


#' Helper function to fix numeric priors
#'
#' @keywords internal
#' @noRd

.fixNumericPriors <- function(priors, pars) {
  #* `if priors is a numeric vector`
  if (is.numeric(priors)) {
    if (length(priors) == length(pars)) {
      warning("Assuming that prior is in order: ", paste0(pars, collapse = ", "))
      priors <- as.list(priors)
      names(priors) <- pars
    } else {
      stop(paste0(
        "`priors` is length ", length(priors), " while the specified model requires ",
        length(pars), " parameters."
      ))
    }
  }
  return(priors)
}

#' Helper function to fix numeric priors
#'
#' @keywords internal
#' @noRd

.formatListPriors <- function(priors, pars, df, group, USEGROUP) {
  if (is.list(priors)) {
    if (is.null(names(priors))) {
      warning("Assuming that each element in priors is in order: ", paste0(pars, collapse = ", "))
      names(priors) <- pars
    }
    priors <- priors[!grepl("fixedChangePoint", names(priors))]
    if (!all(pars %in% names(priors))) {
      warning(paste0(
        "Parameter names and prior names do not match. Priors include ",
        paste(setdiff(names(priors), pars), collapse = ", "),
        "... and parameters include ",
        paste(setdiff(pars, names(priors)), collapse = ", "),
        "... Please rename the misspecified priors."
      ))
    }
    groupedPriors <- any(unlist(lapply(priors, length)) > 1)
    # if any prior has multiple means then groupedPriors is TRUE

    if (groupedPriors) { # if more than one value is specified per parameter
      ml <- max(unlist(lapply(priors, length)))
      priors <- lapply(priors, function(p) rep(p, length.out = ml))
      if (any(unlist(lapply(priors, function(p) !is.null(names(p)))))) {
        # if any inner values are named then apply that to all priors
        wch <- which(unlist(lapply(priors, function(p) !is.null(names(p)))))
        nms <- names(priors[[wch]])
        for (i in seq_along(priors)) {
          names(priors[[i]]) <- nms
        }
      }
      if (any(unlist(lapply(priors, function(p) is.null(names(p)))))) {
        # if no inner values were named
        for (i in seq_along(priors)) {
          names(priors[[i]]) <- unique(df[[group]])
        }
      }
    } else { # else is for prior of length 1 for each element,
      # in which case they need to replicated per groups
      # this should also handle non-grouped formulae
      l <- length(unique(df[[group]]))
      priors <- lapply(priors, rep, length.out = l)
      nms <- unique(df[[group]])
      if (USEGROUP) {
        for (i in seq_along(priors)) {
          names(priors[[i]]) <- nms
        }
      }
    }
  }
  return(list("priors" = priors, "groupedPriors" = groupedPriors))
}


#' Helper function to write stan priors
#'
#' @keywords internal
#' @noRd

.stanStringHelper <- function(priors, pars, USEGROUP) {
  priorStanStrings <- lapply(pars, function(par) {
    if (!grepl("changePoint|I$", par)) {
      paste0("lognormal(log(", priors[[par]], "), 0.25)") # growth parameters are LN
    } else {
      paste0("student_t(5,", priors[[par]], ", 3)") # changepoints/intercepts are T_5(mu, 3)
    }
  })
  priorStanStrings <- unlist(priorStanStrings)
  parNames <- rep(names(priors), each = length(priors[[1]]))
  if (USEGROUP) {
    groupNames <- rep(names(priors[[1]]), length.out = length(priorStanStrings))
    names(priorStanStrings) <- paste(parNames, groupNames, sep = "_")
  } else {
    names(priorStanStrings) <- parNames
  }
  return(priorStanStrings)
}


#' Helper function to write stan priors
#'
#' @keywords internal
#' @noRd

.initializePriorObject <- function(sigma, family) {
  int_only_dpars <- names(sigma[which(sigma == "not_estimated")])
  if (length(int_only_dpars) >= 1) {
    int_dpars_form <- as.formula(paste0(paste(int_only_dpars, collapse = "+"), "~1"))
  } else {
    int_dpars_form <- NULL
  }
  smooth_dpars <- names(sigma[which(sigma %in% c("gam", "spline"))])
  if (length(smooth_dpars) >= 1) {
    smooth_dpars_form <- as.formula(paste0(paste(smooth_dpars, collapse = "+"), "~s(x)"))
  } else {
    smooth_dpars_form <- NULL
  }
  flist <- list(int_dpars_form, smooth_dpars_form)
  flist <- flist[!unlist(lapply(flist, is.null))]
  if (length(flist) == 0) {
    flist <- NULL
  }
  gp <- brms::get_prior(brms::bf(y ~ x, flist = flist),
    data = data.frame(y = 1:100, x = 1:100), family = family
  )
  prior <- rbind(
    gp[1, ], gp[gp$dpar %in% smooth_dpars & gp$class == "Intercept", ],
    gp[gp$dpar %in% int_only_dpars, ]
  )
  return(prior)
}

#' Helper function to explicitly return default priors from get_prior
#'
#' @keywords internal
#' @noRd

.explicitDefaultPrior <- function(formula, df, family) {
  gp <- brms::get_prior(formula = formula, data = df, family = family)
  return(gp)
}

#' Helper function to reformat sigma argument in brmSS
#'
#' @keywords internal
#' @noRd

.sigmaHelper <- function(sigma, dpars, family, models) {
  if (is.null(sigma)) {
    sigma <- lapply(dpars, function(i) {
      "int"
    })
  }
  if (methods::is(sigma, "formula")) {
    sigma <- list(sigma)
  }

  if (length(sigma) > length(dpars)) {
    stop(paste0(
      "sigma contains ", length(sigma), " formulas.",
      "The specified family (", family, ") only has ", length(dpars),
      " valid additional distributional parameters (", paste0(dpars, collapse = ", "), ")."
    ))
  } else if (length(sigma) < length(dpars)) {
    n_to_add <- length(dpars) - length(sigma)
    sigma <- append(sigma, lapply(1:n_to_add, function(i) paste0("not_estimated")))
    names(sigma) <- dpars
  } else { # same length
    names(sigma) <- dpars
  }
  # here I am foregoing pattern matching so that it is simpler to check for intercepts later.
  if (!any(grepl("\\+", sigma))) { # no distributional changepoint models
    sigma <- lapply(sigma, identity)
  }

  return(sigma)
}

#' Helper function to match growth model
#'
#' @keywords internal
#' @noRd

.matchGrowthModel <- function(model, models) {
  if (!grepl("\\+", model)) {
    if (grepl("decay", model)) {
      decay <- TRUE
      model <- trimws(gsub("decay", "", model))
    } else {
      decay <- FALSE
    }
    matched_model <- match.arg(model, models)
  } else {
    matched_model <- model
    decay <- FALSE
  }
  return(list("model" = matched_model, "decay" = decay))
}



#' Helper function for logistic brms formulas
#'
#' @keywords internal
#' @noRd

.brms_form_logistic <- function(x, y, group, dpar = FALSE,
                                nTimes = NULL, useGroup = TRUE, prior = NULL, int = FALSE) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + ", y, "A/(1+exp((",
        y, "B-", x, ")/", y, "C))"
      )))
      pars <- paste0(y, LETTERS[c(1:3, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "A/(1+exp((",
        y, "B-", x, ")/", y, "C))"
      )))
      pars <- paste0(y, LETTERS[1:3])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + (A/(1+exp((B-", x, ")/C)))"))
      pars <- LETTERS[c(1:3, 9)]
    } else {
      form <- stats::as.formula(paste0(y, " ~ A/(1+exp((B-", x, ")/C))"))
      pars <- LETTERS[1:3]
    }
  }
  return(list(form = form, pars = pars))
}
#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd

.brms_form_gompertz <- function(x, y, group, dpar = FALSE,
                                nTimes = NULL, useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + (",
        y, "A*exp(-", y, "B*exp(-", y, "C*", x, ")))"
      )))
      pars <- paste0(y, LETTERS[c(1:3, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ",
        y, "A*exp(-", y, "B*exp(-", y, "C*", x, "))"
      )))
      pars <- paste0(y, LETTERS[1:3])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + (A*exp(-B*exp(-C*", x, ")))"))
      pars <- LETTERS[c(1:3, 9)]
    } else {
      form <- stats::as.formula(paste0(y, " ~ A*exp(-B*exp(-C*", x, "))"))
      pars <- LETTERS[1:3]
    }
  }
  return(list(form = form, pars = pars))
}
#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd


.brms_form_doublelogistic <- function(x, y, group, dpar = FALSE,
                                      nTimes = NULL, useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + (", y,
        "A/(1+exp((", y, "B-", x, ")/", y, "C)) + ((",
        y, "A2-", y, "A) /(1+exp((", y, "B2-", x,
        ")/", y, "C2))))"
      )))
      pars <- paste0(y, c("I", "A", "B", "C", "A2", "B2", "C2"))
    } else {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y,
        "A/(1+exp((", y, "B-", x, ")/", y, "C)) + ((",
        y, "A2-", y, "A) /(1+exp((", y, "B2-", x,
        ")/", y, "C2)))"
      )))
      pars <- paste0(y, c("A", "B", "C", "A2", "B2", "C2"))
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(
        y, " ~ I + (A/(1+exp((B-", x, ")/C)) + ((A2-A) /(1+exp((B2-", x, ")/C2))))"
      ))
      pars <- c("I", "A", "B", "C", "A2", "B2", "C2")
    } else {
      form <- stats::as.formula(paste0(
        y, " ~ A/(1+exp((B-", x, ")/C)) + ((A2-A) /(1+exp((B2-", x, ")/C2)))"
      ))
      pars <- c("A", "B", "C", "A2", "B2", "C2")
    }
  }
  return(list(form = form, pars = pars))
}
#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd


.brms_form_doublegompertz <- function(x, y, group, dpar = FALSE,
                                      nTimes = NULL, useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + (", y, "A * exp(-", y, "B * exp(-", y,
        "C*", x, ")) + (", y, "A2-", y, "A) * exp(-", y,
        "B2 * exp(-", y, "C2*(", x, "-", y, "B))))"
      )))
      pars <- paste0(y, c("I", "A", "B", "C", "A2", "B2", "C2"))
    } else {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "A * exp(-", y, "B * exp(-", y,
        "C*", x, ")) + (", y, "A2-", y, "A) * exp(-", y,
        "B2 * exp(-", y, "C2*(", x, "-", y, "B)))"
      )))
      pars <- paste0(y, c("A", "B", "C", "A2", "B2", "C2"))
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(
        y, " ~ I + (A * exp(-B * exp(-C*", x,
        ")) + (A2-A) * exp(-B2 * exp(-C2*(", x, "-B))))"
      ))
      pars <- c("I", "A", "B", "C", "A2", "B2", "C2")
    } else {
      form <- stats::as.formula(paste0(
        y, " ~ A * exp(-B * exp(-C*", x,
        ")) + (A2-A) * exp(-B2 * exp(-C2*(", x, "-B)))"
      ))
      pars <- c("A", "B", "C", "A2", "B2", "C2")
    }
  }
  return(list(form = form, pars = pars))
}
#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd


.brms_form_monomolecular <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                                     useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + (",
        y, "A-", y, "A*exp(-", y, "B*", x, "))"
      )))
      pars <- paste0(y, LETTERS[c(1:2, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(y, " ~ ", y, "A-", y, "A*exp(-", y, "B*", x, ")")))
      pars <- paste0(y, LETTERS[1:2])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, "~I + (A-A*exp(-B*", x, "))"))
      pars <- LETTERS[c(1:2, 9)]
    } else {
      form <- stats::as.formula(paste0(y, "~A-A*exp(-B*", x, ")"))
      pars <- LETTERS[1:2]
    }
  }
  return(list(form = form, pars = pars))
}
#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd


.brms_form_exponential <- function(x, y, group, dpar = FALSE,
                                   nTimes = NULL, useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ",
        y, "I + (", y, "A*exp(", y, "B*", x, "))"
      )))
      pars <- paste0(y, LETTERS[c(1:2, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(y, " ~ ", y, "A*exp(", y, "B*", x, ")")))
      pars <- paste0(y, LETTERS[1:2])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + (A*exp(B*", x, "))"))
      pars <- LETTERS[c(1:2, 9)]
    } else {
      form <- stats::as.formula(paste0(y, " ~ A*exp(B*", x, ")"))
      pars <- LETTERS[1:2]
    }
  }
  return(list(form = form, pars = pars))
}
#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd


.brms_form_linear <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                              useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (!is.null(prior) && any(grepl(paste0(y, "A"), names(prior)))) {
      #* use non-linear parameterization with subA
      if (int) {
        form <- brms::nlf(stats::as.formula(paste0(y, " ~ ", y, "I + (", y, "A", "*", x, ")")))
        pars <- c(paste0(y, c("I", "A")))
      } else {
        form <- brms::nlf(stats::as.formula(paste0(y, " ~ ", y, "A", "*", x)))
        pars <- c(paste0(y, "A"))
      }
    } else {
      #* linear parameterization using x directly, no intercept option
      if (int) {
        form <- brms::nlf(as.formula(paste0(y, " ~ ", y, "I + (", x, "+", x, ":", group, ")")))
        pars <- paste0(y, "I")
      } else {
        form <- as.formula(paste0(y, " ~ ", x, "+", x, ":", group))
        pars <- c()
      }
    }
  } else { # non-dpar option, with or without intercept
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + A*", x))
      pars <- c("I", "A")
    } else {
      form <- stats::as.formula(paste0(y, " ~ A*", x))
      pars <- c("A")
    }
  }
  return(list(form = form, pars = pars))
}

#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd


.brms_form_logarithmic <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                                   useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(y, " ~ ", y, "I + (", y, "A*log(", x, "))")))
      pars <- paste0(y, LETTERS[c(1, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(y, " ~ ", y, "A*log(", x, ")")))
      pars <- paste0(y, "A")
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + (A*log(", x, "))"))
      pars <- LETTERS[c(1, 9)]
    } else {
      form <- stats::as.formula(paste0(y, " ~ A*log(", x, ")"))
      pars <- "A"
    }
  }
  return(list(form = form, pars = pars))
}

#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd


.brms_form_powerlaw <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                                useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(y, " ~ ", y, "I + (", y, "A*", x, "^", y, "B)")))
      pars <- paste0(y, LETTERS[c(1:2, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(y, " ~ ", y, "A*", x, "^", y, "B")))
      pars <- paste0(y, LETTERS[1:2])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + (A*", x, "^B)"))
      pars <- LETTERS[c(1:2, 9)]
    } else {
      form <- stats::as.formula(paste0(y, " ~ A*", x, "^B"))
      pars <- LETTERS[1:2]
    }
  }
  return(list(form = form, pars = pars))
}
#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd


.brms_form_gam <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                           useGroup = TRUE, prior = NULL, int) {
  if (useGroup) {
    by <- paste0(", by = ", group)
  } else {
    by <- ","
  }
  if (nTimes < 11) {
    k <- paste0(", k = ", nTimes)
  } else {
    k <- NULL
  }

  form <- stats::as.formula(paste0(y, " ~ s(", x, by, k, ")"))
  pars <- NULL

  return(list(form = form, pars = pars))
}
#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd


.brms_form_int <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                           useGroup = TRUE, prior = NULL, int) {
  if (useGroup) {
    rhs <- paste0("0 + ", group)
  } else {
    rhs <- paste0("1")
  }
  form <- stats::as.formula(paste0(y, " ~ ", rhs))
  pars <- c()
  return(list(form = form, pars = pars))
}

#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd


.brms_form_not_estimated <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                                     useGroup = TRUE, prior = NULL, int) {
  form <- stats::as.formula(paste0(y, " ~ 1"))
  pars <- c()
  return(list(form = form, pars = pars))
}

#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd

.brms_form_decay <- function(formList, int = FALSE) {
  modelForm <- formList$form
  chars <- as.character(modelForm)
  if (!int) {
    formList$form <- as.formula(paste0(chars[2], chars[1], "-(", chars[3], ")"))
  } else {
    rhs <- chars[3]
    rhs <- trimws(gsub("I\\s?\\+", "", rhs))
    formList$form <- as.formula(paste0(chars[2], chars[1], "I - (", rhs, ")"))
  }
  formList
}

#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd

.brms_form_frechet <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                               useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + (", y, "A * exp(-((", x, "-0)/", y, "C)^(-", y, "B)))"
      )))
      pars <- paste0(y, LETTERS[c(1:3, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "A * exp(-((", x, "-0)/", y, "C)^(-", y, "B))"
      )))
      pars <- paste0(y, LETTERS[1:3])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + (A * exp(-((", x, "-0)/C)^(-B)))"))
      pars <- LETTERS[c(1:3, 9)]
    } else {
      form <- stats::as.formula(paste0(y, " ~ A * exp(-((", x, "-0)/C)^(-B))"))
      pars <- LETTERS[1:3]
    }
  }
  return(list(form = form, pars = pars))
}

#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd

.brms_form_weibull <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                               useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + (", y, "A * (1-exp(-(", x, "/", y, "C)^", y, ")))"
      )))
      pars <- paste0(y, LETTERS[c(1:3, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "A * (1-exp(-(", x, "/", y, "C)^", y, "))"
      )))
      pars <- paste0(y, LETTERS[1:3])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + (A * (1-exp(-(", x, "/C)^B)))"))
      pars <- LETTERS[c(1:3, 9)]
    } else {
      form <- stats::as.formula(paste0(y, " ~ A * (1-exp(-(", x, "/C)^B))"))
      pars <- LETTERS[1:3]
    }
  }
  return(list(form = form, pars = pars))
}

#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd

.brms_form_gumbel <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                              useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + (", y, "A * exp(-exp( -(", x, "-", y, "B)/", y, "C)))"
      )))
      pars <- paste0(y, LETTERS[c(1:3, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "A * exp(-exp( -(", x, "-", y, "B)/", y, "C))"
      )))
      pars <- paste0(y, LETTERS[1:3])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + (A * exp(-exp( -(", x, "-B)/C)))"))
      pars <- LETTERS[c(1:3, 9)]
    } else {
      form <- stats::as.formula(paste0(y, " ~ A * exp(-exp( -(", x, "-B)/C))"))
      pars <- LETTERS[1:3]
    }
  }
  return(list(form = form, pars = pars))
}

#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd

.brms_form_bragg <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                             useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + ", y, "A * exp(-", y, "B * (", x, " - ", y, "C)^2)"
      )))
      pars <- paste0(y, LETTERS[c(1:3, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "A * exp(-", y, "B * (", x, " - ", y, "C)^2)"
      )))
      pars <- paste0(y, LETTERS[1:3])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + A * exp(-B * (", x, " - C)^2)"))
      pars <- LETTERS[c(1:3, 9)]
    } else {
      form <- stats::as.formula(paste0(y, " ~ A * exp(-B * (", x, " - C)^2)"))
      pars <- LETTERS[1:3]
    }
  }
  return(list(form = form, pars = pars))
}

#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd

.brms_form_lorentz <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                               useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + ", y, "A / (1 + ", y, "B * (", x, " - ", y, "C) ^ 2)"
      )))
      pars <- paste0(y, LETTERS[c(1:3, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "A / (1 + ", y, "B * (", x, " - ", y, "C) ^ 2)"
      )))
      pars <- paste0(y, LETTERS[1:3])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(y, " ~ I + A / (1 + B * (", x, " - C) ^ 2)"))
      pars <- LETTERS[c(1:3, 9)]
    } else {
      form <- stats::as.formula(paste0(y, " ~ A / (1 + B * (", x, " - C) ^ 2)"))
      pars <- LETTERS[1:3]
    }
  }
  return(list(form = form, pars = pars))
}

#' Helper function for brms formulas
#'
#' @keywords internal
#' @noRd

.brms_form_beta <- function(x, y, group, dpar = FALSE, nTimes = NULL,
                            useGroup = TRUE, prior = NULL, int) {
  if (dpar) {
    if (int) {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "I + ", y, "A * (((", x, " - ", y, "D) / (", y, "C - ", y, "D)) * ((", y, "E - ", x,
        ") / (", y, "E - ", y, "C)) ^ ((", y, "E - ", y, "C) / (", y, "C - ", y, "D))) ^ ", y, "B"
      )))
      pars <- paste0(y, LETTERS[c(1:5, 9)])
    } else {
      form <- brms::nlf(stats::as.formula(paste0(
        y, " ~ ", y, "A * (((", x, " - ", y, "D) / (", y, "C - ", y, "D)) * ((", y, "E - ", x,
        ") / (", y, "E - ", y, "C)) ^ ((", y, "E - ", y, "C) / (", y, "C - ", y, "D))) ^ ", y, "B"
      )))
      pars <- paste0(y, LETTERS[1:5])
    }
  } else {
    if (int) {
      form <- stats::as.formula(paste0(
        y, " ~ I + A * (((", x, " - D) / (C - D)) * ((E - ", x,
        ") / (E - C)) ^ ((E - C) / (C - D))) ^ B"
      ))
      pars <- LETTERS[c(1:5, 9)]
    } else {
      form <- stats::as.formula(paste0(
        y, " ~ A * (((", x, " - D) / (C - D)) * ((E - ", x,
        ") / (E - C)) ^ ((E - C) / (C - D))) ^ B"
      ))
      pars <- LETTERS[1:5]
    }
  }
  return(list(form = form, pars = pars))
}

#' Time conversion and plotting for bellwether data
#'
#' @param df Data frame to use, this can be in wide or long format.
#' @param mode One of "DAS", "DAP" or "DAE" (Days After Planting and Days After Emergence).
#' Defaults to adding all columns.
#' Note that if timeCol is not an integer then DAS is always returned.
#' @param plantingDelay If `mode` includes "DAP" then `plantingDelay` is used to adjust "DAS"
#' @param phenotype If `mode` includes "DAE" then this is the phenotype used to classify emergence.
#' @param cutoff If `mode` inlcludes "DAE" then this value is used to classify emergence.
#' Defaults to 1, meaning an image with a value of 1 or more for `phenotype` has "emerged".
#' @param timeCol Column of input time values, defaults to "timestamp".
#' If this is not an integer then it is assumed to be
#' a timestamp in the format of the format argument.
#' @param group  Grouping variables to specify unique plants as a character vector.
#' This defaults to "Barcodes". These taken together should identify a unique plant across time,
#' although often "angle" or "rotation" should be added.
#' @param plot Logical, should plots of the new time variables be printed?
#' @param format An R POSIXct format, defaults to lemnatech standard format.
#' This is only used if timeCol is not an integer.
#' @param traitCol Column with phenotype names, defaults to "trait".
#' This should generally not need to be changed from the default.
#'    If this and valueCol are present in colnames(df) then the data
#'    is assumed to be in long format.
#' @param valueCol Column with phenotype values, defaults to "value".
#' This should generally not need to be changed from the default.
#' @param index Optionally a time to use as the beginning of the experiment. This
#' may be useful if you have multiple datasets or you are adding data from bw.water
#' and plants were watered before being imaged or if you want to index days off of
#' midnight. This defaults to NULL but will take any value coercible to POSIXct by
#' \code{as.POSIXct(... , tz="UTC")} such as "2020-01-01 18:30:00"
#' @keywords DAS time ggplot
#' @import ggplot2
#' @return The input dataframe with new integer columns for different ways
#' of describing time in the experiment. If plot is TRUE then a ggplot is also returned as part of
#' a list.
#' @export
#' @examples
#' \donttest{
#' sv <- read.pcv(
#'   "https://raw.githubusercontent.com/joshqsumner/pcvrTestData/main/pcv4-single-value-traits.csv",
#'   mode = "wide", reader = "fread"
#' )
#' sv$genotype = substr(sv$barcode, 3, 5)
#' sv$genotype = ifelse(sv$genotype == "002", "B73",
#'   ifelse(sv$genotype == "003", "W605S",
#'     ifelse(sv$genotype == "004", "MM", "Mo17")
#'   )
#' )
#' sv$fertilizer = substr(sv$barcode, 8, 8)
#' sv$fertilizer = ifelse(sv$fertilizer == "A", "100",
#'   ifelse(sv$fertilizer == "B", "50", "0")
#' )
#' sv <- bw.time(sv,
#'   plantingDelay = 0, phenotype = "area_pixels", cutoff = 10,
#'   timeCol = "timestamp", group = c("barcode", "rotation"), plot = FALSE
#' )
#'
#'
#' svl <- read.pcv(
#'   "https://raw.githubusercontent.com/joshqsumner/pcvrTestData/main/pcv4-single-value-traits.csv",
#'   mode = "long", reader = "fread"
#' )
#' svl$genotype = substr(svl$barcode, 3, 5)
#' svl$genotype = ifelse(svl$genotype == "002", "B73",
#'   ifelse(svl$genotype == "003", "W605S",
#'     ifelse(svl$genotype == "004", "MM", "Mo17")
#'   )
#' )
#' svl$fertilizer = substr(svl$barcode, 8, 8)
#' svl$fertilizer = ifelse(svl$fertilizer == "A", "100",
#'   ifelse(svl$fertilizer == "B", "50", "0")
#' )
#' svl <- bw.time(svl,
#'   plantingDelay = 0, phenotype = "area_pixels", cutoff = 10, timeCol = "timestamp",
#'   group = c("barcode", "rotation"), plot = FALSE
#' )
#' }
#'
bw.time <- function(df = NULL, mode = c("DAS", "DAP", "DAE"), plantingDelay = NULL,
                    phenotype = NULL, cutoff = 1, timeCol = "timestamp",
                    group = "Barcodes", plot = TRUE, format = "%Y-%m-%d %H:%M:%S",
                    traitCol = "trait", valueCol = "value", index = NULL) {
  wide <- .detectWideData(df, traitCol, valueCol) # see bwoutliers

  if (is.null(plantingDelay) && "DAP" %in% mode) {
    mode <- mode[-which(mode == "DAP")]
  }
  if (is.null(phenotype) && "DAE" %in% mode) {
    mode <- mode[-which(mode == "DAE")]
  }

  formatNonIntegerTimeRes <- .formatNonIntegerTime(df, timeCol, format, index)
  df <- formatNonIntegerTimeRes[["data"]]
  timeCol <- formatNonIntegerTimeRes[["timeCol"]]

  if ("DAP" %in% mode) {
    df$DAP <- df[[timeCol]] + plantingDelay
  }
  if ("DAE" %in% mode) {
    df <- .daeHelper(df, group, wide, phenotype, cutoff, timeCol, traitCol, valueCol)
  }

  rownames(df) <- NULL
  if (plot) {
    p <- .timePlottingHelper(df, phenotype, group, wide, mode, traitCol, valueCol)
    df <- list("data" = df, "plot" = p)
  }
  return(df)
}

#' ***********************************************************************************************
#' *************** `fix non date times` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for time handling
#'
#' @keywords internal
#' @noRd

.formatNonIntegerTime <- function(df, timeCol, format, index) {
  if (!is.integer(df[[timeCol]])) {
    df[[timeCol]] <- as.POSIXct(strptime(df[[timeCol]], format = format))
    beg <- as.POSIXct(index, tz = "UTC")
    if (is.null(index)) {
      beg <- min(df[[timeCol]], na.rm = TRUE)
    }
    df$DAS <- floor(as.numeric((df[[timeCol]] - beg) / 60 / 60 / 24))
    timeCol <- "DAS"
  }
  return(list("data" = df, "timeCol" = timeCol))
}


#' ***********************************************************************************************
#' *************** `time plotting Helper` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for plotting time data
#'
#' @keywords internal
#' @noRd

.timePlottingHelper <- function(df, phenotype, group, wide, mode, traitCol, valueCol) {
  if (wide) {
    plotDat <- df
    plotDat$plotGroup <- interaction(plotDat[, c(group)])
    p <- lapply(mode, function(m) {
      ggplot2::ggplot(plotDat, ggplot2::aes(
        x = .data[[m]], y = .data[[phenotype]],
        group = .data$plotGroup
      )) +
        ggplot2::geom_line() +
        ggplot2::labs(x = m, y = phenotype, title = m) +
        pcv_theme()
    })
    return(p)
  } else if (!wide) {
    plotDat <- df[df[[traitCol]] == phenotype, ]
    plotDat$plotGroup <- interaction(plotDat[, c(group)])
    p <- lapply(mode, function(m) {
      ggplot2::ggplot(plotDat, ggplot2::aes(
        x = .data[[m]], y = .data[[valueCol]],
        group = .data$plotGroup
      )) +
        ggplot2::geom_line() +
        ggplot2::labs(x = m, y = phenotype, title = m) +
        pcv_theme()
    })
    return(p)
  }
}

#' ***********************************************************************************************
#' *************** `DAE Helper` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for dae calculation
#'
#' @keywords internal
#' @noRd

.daeHelper <- function(df, group, wide, phenotype, cutoff, timeCol, traitCol, valueCol) {
  if (wide) {
    dae_split <- interaction(df[, group])
    df <- do.call(rbind, lapply(split(df, dae_split), function(d) {
      subd <- d[d[[phenotype]] >= cutoff & !is.na(d[[phenotype]]), ]
      if (nrow(subd) == 0) {
        subd <- data.frame(DAS = max(df[[timeCol]]) + 1)
        colnames(subd) <- timeCol
      } # if all NA area then remove all rows
      d$DAE <- d[[timeCol]] - min(subd[[timeCol]], na.rm = TRUE)
      d
    }))
  } else {
    dae_split <- interaction(df[, group])
    df <- do.call(rbind, lapply(split(df, dae_split), function(d) {
      subd <- d[d[[traitCol]] == phenotype & d[[valueCol]] >= cutoff & !is.na(d[[valueCol]]), ]
      if (nrow(subd) == 0) {
        subd <- data.frame(DAS = max(df[[timeCol]]) + 1)
        colnames(subd) <- timeCol
      }
      d$DAE <- d[[timeCol]] - min(subd[[timeCol]], na.rm = TRUE)
      d
    }))
  }
  return(df)
}

#' @description
#' Internal function for calculating posterior distribution of \Lambda parameter for poisson data.
#' The conjugate prior on Lambda is a Gamma(A,B)
#' A=B=0.5 is a reasonable weak default prior
#'
#' So if leaf count is Poisson distributed:
#' count ~ Pois(\labmda)
#' \labmda ~ gamma(A, B)
#' A = A_[prior] + sum(x)
#' B = B_[prior] / (1+n)
#'
#' via MoM \hat(\labmda) =  = 1/n +sum^1_n(x)
#' @param s1 A vector of numerics drawn from a beta distribution.
#' @examples
#'
#' .conj_poisson_sv(
#'   s1 = rpois(20, 10), priors = list(a = c(0.5, 0.5), b = c(0.5, 0.5)),
#'   plot = FALSE
#' )
#'
#' @keywords internal
#' @noRd

.conj_poisson_sv <- function(s1 = NULL, priors = NULL,
                             plot = FALSE, support = NULL, cred.int.level = NULL,
                             calculatingSupport = FALSE) {
  #* `Check samples`
  if (any(abs(s1 - round(s1)) > .Machine$double.eps^0.5) || any(s1 < 0)) {
    stop("Only positive integers can be used in the Poisson distribution")
  }
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(a = 0.5, b = 0.5) # gamma prior on lambda
  }

  out <- list()

  #* `Use conjugate gamma prior on lambda`
  a1_prime <- priors$a[1] + sum(s1)
  b1_prime <- priors$b[1] + length(s1)
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qgamma(c(0.0001, 0.9999), a1_prime, b1_prime)
    return(quantiles)
  }
  #* `calculate density over support``
  dens1 <- dgamma(support, a1_prime, b1_prime)
  pdf1 <- dens1 / sum(dens1)

  #* `calculate highest density interval`
  hdi1 <- qgamma(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), a1_prime, b1_prime)

  #* `calculate highest density estimate``
  hde1 <- .gammaHDE(shape = a1_prime, scale = 1 / b1_prime)

  #* `save summary and parameters`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior$a <- a1_prime
  out$posterior$b <- b1_prime
  #* `Make Posterior Draws`
  out$posteriorDraws <- rgamma(10000, a1_prime, b1_prime)
  out$pdf <- pdf1
  #* `keep data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support, "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' Function to visualize models made by \link{fitGrowth}.
#'
#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
#' (and similar models made through other means) can be visualized easily using this function.
#'
#'
#' @param fit A model fit object (or a list of \code{nlrq} models) as returned by \code{fitGrowth}.
#' @param form A formula similar to that in \code{growthSS} inputs (or the \code{pcvrForm} part of the
#' output) specifying the outcome, predictor, and grouping structure of the data as
#' \code{outcome ~ predictor|individual/group}. Generally this is given directly from
#' the growthSS output (\code{ss$pcvrForm}). If the formula does not include both individuals
#' and groups then lines from the data will not be plotted which may be best if your data does not
#' specify unique individuals and your model does not include autocorrelation.
#' @param groups An optional set of groups to keep in the plot.
#' Defaults to NULL in which case all groups in the model are plotted.
#' @param df A dataframe to use in plotting observed growth curves on top of the model and for making
#' predictions.
#' @param timeRange An optional range of times to use. This can be used to view predictions for
#' future data if the avaiable data has not reached some point (such as asymptotic size).
#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
#' @param groupFill logical, should groups have different colors? Defaults to the opposite of
#' facetGroups. If TRUE then
#' viridis colormaps are used in the order c('plasma', 'mako', 'viridis', 'inferno', 'cividis', 'magma',
#' 'turbo', 'rocket'). Alternatively this can be given as a vector of
#' viridis colormap names to use in a different order than above.
#' Note that for brms models this is ignored except if used to specify a different viridis color map
#' to use.
#' @param hierarchy_value If a hierarchical model is being plotted, what value should the
#' hiearchical predictor be? If left NULL (the default) the mean value is used.
#' @keywords growth-curve
#' @importFrom methods is
#' @examples
#'
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   df = simdf, type = "nls"
#' )
#' fit <- fitGrowth(ss)
#' growthPlot(fit, form = ss$pcvrForm, df = ss$df)
#'
#' @return Returns a ggplot showing a brms model's credible
#' intervals and optionally the individual growth lines.
#'
#' @export

growthPlot <- function(fit, form, groups = NULL, df = NULL, timeRange = NULL,
                       facetGroups = TRUE, groupFill = !facetGroups, hierarchy_value = NULL) {
  if (is.logical(groupFill)) {
    virMaps <- c("plasma", "mako", "viridis", "inferno", "cividis", "magma", "turbo", "rocket")
  } else {
    virMaps <- groupFill
    groupFill <- TRUE
  }
  model_class <- class(fit)[1]
  if (methods::is(fit, "list")) {
    model_class <- class(fit[[1]])
  }
  if (methods::is(fit, "brmsfit")) {
    if (attr(fit$formula$formula, "nl")) { # non linear models are growth models
      plot <- brmPlot(
        fit = fit, form = form, groups = groups, df = df, timeRange = timeRange,
        facetGroups = facetGroups, hierarchy_value = hierarchy_value, vir_option = virMaps[1]
      )
    } else { # linear models are survival models
      plot <- brmSurvPlot(
        fit = fit, form = form, groups = groups, df = df, timeRange = timeRange,
        facetGroups = facetGroups
      )
    }
  } else {
    plottingFunction <- match.fun(paste0(model_class, "Plot"))
    plot <- plottingFunction(
      fit = fit, form = form, groups = groups, df = df, timeRange = timeRange,
      facetGroups = facetGroups, groupFill = groupFill, virMaps
    )
  }
  return(plot)
}

#' Ease of use nlme starter function for standard growth model parameterizations
#'
#' Internal to growthSS
#'
#' @param model One of the 8 model options in growthSS
#' @param form A pcvr style form, see growthSS
#' @param sigma One of "int", "power", or "exp", which will correspond to varIdent, varPower, or varExp
#' respectively.
#' This can also take a varFunc object.
#' @param df a dataframe to use to make the model.
#' @param pars optional parameters to vary by group as fixed effects.
#' @param start Starting values. These are optional unless model is a double sigmoid.
#' For any other model these will be estimated from the data if left NULL.
#'
#' @examples
#'
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#'
#' ss <- .nlmeSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   sigma = "power", df = simdf, start = NULL
#' )
#'
#' ss <- .nlmeSS(
#'   model = "gam", form = y ~ time | id / group,
#'   sigma = "power", df = simdf, start = NULL
#' )
#'
#' dim(ss$df)
#' ss[c("formula", "taus", "start", "pcvrForm")]
#'
#' @import lmeSplines
#' @importFrom nlme varPower varIdent varExp nlme nlme.formula corAR1 pdIdent
#' @importFrom stats as.formula setNames
#' @importFrom methods is
#'
#' @keywords internal
#' @noRd


.nlmeSS <- function(model, form, sigma, df, pars = NULL, start = NULL, int = FALSE) {
  #* `general steps`
  #* ***** `Define choices and make empty output list`
  out <- list()
  models <- c(
    "logistic", "gompertz", "monomolecular",
    "exponential", "linear", "power law",
    "double logistic", "double gompertz", "gam",
    "frechet", "weibull", "gumbel", "logarithmic", "bragg", "lorentz", "beta"
  )
  sigmas <- c("none", "int", "power", "exp")
  #* check if sigma is class "varFunc", if it is then return it as is?

  #* ***** `Make nlme model formula` *****
  #* `parse form argument`
  parsed_form <- .parsePcvrForm(form, df)
  y <- parsed_form$y
  x <- parsed_form$x
  individual <- parsed_form$individual
  group <- parsed_form$group
  df <- parsed_form$data

  #* `make group a factor for nlme`
  df[[group]] <- as.factor(df[[group]])
  df[[paste0(group, "_numericLabel")]] <- unclass(df[[group]])
  #* `make an interaction variable for autocorrelation`
  #* Note that nlme does not allow random effects and correlations to apply at different "scales"
  #* so A,B,C can either vary by this interaction variable to have autocorrelation accurately modeled
  #* OR A,B,C can be estimated by group and autocorrelation can be by group. Currently this option is
  #* used. This note is kept here for reference.
  df[[paste0(group, individual)]] <- interaction(df[[group]], df[[individual]])

  #* `assemble growth formula with FE, RE, Groups, and Weights`
  if (grepl("decay", model)) {
    decay <- TRUE
    model <- trimws(gsub("decay", "", model))
  } else {
    decay <- FALSE
  }

  matched_model <- match.arg(model, models)

  if (is.character(sigma)) {
    matched_sigma <- match.arg(sigma, sigmas)
  } else {
    matched_sigma <- sigma
  }

  stringFormFun <- paste0(".nlme_form_", gsub(" ", "", matched_model))
  form_fun <- match.fun(stringFormFun)
  if (matched_model == "gam") { # gam takes some extra work
    df$splines <- lmeSplines::smspline(as.formula(paste0("~ ", x)), data = df) # spline setup
    start <- 0 # no starting values (no parameters)
    pars <- df # there are no pars, this is just to pass df to pdIdent for the splines
  }
  growthFormList <- form_fun(x, y, group, individual, matched_sigma, pars, int)
  pars <- growthFormList$pars
  growthFormList <- growthFormList[!grepl("pars", names(growthFormList))]
  if (decay) {
    growthFormList <- .nlmeDecay(growthFormList)
  }

  #* `Make starting values`
  if (matched_model == "gam") {
    start <- 0
  }
  if (is.null(start)) {
    if (grepl("double", matched_model)) {
      warning(paste0(
        "Double Sigmoid models are not supported as self-starting models, ",
        "you will need to add starting parameters.",
        "Note for these models type='brms' is recommended."
      ))
      startingValues <- NULL
    } else {
      stringInitFun <- paste0(".init", gsub(" ", "", matched_model))
      initFunction <- match.fun(stringInitFun)
      startingValues <- initFunction(df, x, y, int)
    }
    startingValuesList <- unlist(lapply(names(startingValues), function(nm) {
      val <- startingValues[nm]
      if (nm %in% pars) {
        rep(val, length(unique(df[[group]])))
        # if this is one of pars then make starting value per group
      } else {
        val
      } # else return one starting value
    }))
  } else {
    startingValuesList <- start
  }

  #* `return model components`

  out[["formula"]] <- growthFormList
  out[["start"]] <- startingValuesList
  out[["df"]] <- df
  out[["pcvrForm"]] <- form
  return(out)
}



#* `Sigma matching helper function`

.nlme_sigma_form <- function(matched_sigma, x, group) {
  if (group == "dummyGroup") {
    group <- NULL
  }
  #* `variance formula`
  if (methods::is(matched_sigma, "varFunc")) {
    weights_form <- matched_sigma
  } else if (matched_sigma %in% c("int", "none")) {
    weights_form <- nlme::varIdent(
      form = stats::as.formula(paste(c("~1", group), collapse = "|"))
    )
  } else if (matched_sigma == "power") {
    weights_form <- nlme::varPower(
      form = stats::as.formula(paste(c(paste0("~", x), group), collapse = "|"))
    )
  } else if (matched_sigma == "exp") {
    weights_form <- nlme::varExp(
      form = stats::as.formula(paste(c(paste0("~", x), group), collapse = "|"))
    )
  }
  if (is.null(group)) {

  }
  return(weights_form)
}


#* `Define growth formulas`

.nlme_form_logistic <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ I + (A/(1+exp((B-", x, ")/C)))"))
  } else {
    total_pars <- c("A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ A/(1+exp((B-", x, ")/C))"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_gompertz <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ I + (A*exp(-B*exp(-C*", x, ")))"))
  } else {
    total_pars <- c("A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ A*exp(-B*exp(-C*", x, "))"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_doublelogistic <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B", "C", "A2", "B2", "C2")
    model_form <- as.formula(paste0(
      y, " ~ I + (A/(1+exp((B-", x,
      ")/C)) + ((A2-A) /(1+exp((B2-", x,
      ")/C2))))"
    ))
  } else {
    total_pars <- c("A", "B", "C", "A2", "B2", "C2")
    model_form <- as.formula(paste0(
      y, " ~ A/(1+exp((B-", x,
      ")/C)) + ((A2-A) /(1+exp((B2-", x,
      ")/C2)))"
    ))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_doublegompertz <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B", "C", "A2", "B2", "C2")
    model_form <- as.formula(paste0(
      y, " ~ I + (A * exp(-B * exp(-C*", x,
      ")) + (A2-A) * exp(-B2 * exp(-C2*(", x, "-B))))"
    ))
  } else {
    total_pars <- c("A", "B", "C", "A2", "B2", "C2")
    model_form <- as.formula(paste0(
      y, " ~ A * exp(-B * exp(-C*", x,
      ")) + (A2-A) * exp(-B2 * exp(-C2*(", x, "-B)))"
    ))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_monomolecular <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B")
    model_form <- as.formula(paste0(y, "~I + (A-A*exp(-B*", x, "))"))
  } else {
    total_pars <- c("A", "B")
    model_form <- as.formula(paste0(y, "~A-A*exp(-B*", x, ")"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_exponential <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B")
    model_form <- as.formula(paste0(y, " ~ I + (A*exp(B*", x, "))"))
  } else {
    total_pars <- c("A", "B")
    model_form <- as.formula(paste0(y, " ~ A*exp(B*", x, ")"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_linear <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A")
    model_form <- as.formula(paste0(y, " ~ I + A*", x))
  } else {
    total_pars <- c("A")
    model_form <- as.formula(paste0(y, " ~ A*", x))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_logarithmic <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A")
    model_form <- as.formula(paste0(y, " ~ I + A*log(", x, ")"))
  } else {
    total_pars <- c("A")
    model_form <- as.formula(paste0(y, " ~ A*log(", x, ")"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}


.nlme_form_powerlaw <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B")
    model_form <- as.formula(paste0(y, " ~ I + (A*", x, "^B)"))
  } else {
    total_pars <- c("A", "B")
    model_form <- as.formula(paste0(y, " ~ A*", x, "^B"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}



.nlme_form_gam <- function(x, y, group, individual, matched_sigma, pars, int) {
  model_form <- as.formula(paste0(y, " ~", x, "*", group))
  #* `random effects formula`
  random_form <- stats::setNames(list(nlme::pdIdent(~ splines - 1, data = pars)), group)
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  #* nlme insists that correlation and RE formulas use the same grouping,
  #* so i will not be able to account for individual autocorrelation in the GAM option
  correlation_form <- nlme::corAR1(0.8, form = stats::as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlmeDecay <- function(formList) {
  modelForm <- formList$model
  chars <- as.character(modelForm)
  formList$model <- as.formula(paste0(chars[2], chars[1], "-(", chars[3], ")"))
  formList
}



.nlme_form_weibull <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ I + (A * (1-exp(-(", x, "/C)^B)))"))
  } else {
    total_pars <- c("A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ A * (1-exp(-(", x, "/C)^B))"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_frechet <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ I + (A * exp(-((", x, "-0)/C)^(-B)))"))
  } else {
    total_pars <- c("A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ A * exp(-((", x, "-0)/C)^(-B))"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}


.nlme_form_gumbel <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ I + (A * exp(-exp(-(", x, "-B)/C)))"))
  } else {
    total_pars <- c("A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ A * exp(-exp(-(", x, "-B)/C))"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_bragg <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ I + A * exp(-B * (", x, " - C)^2)"))
  } else {
    total_pars <- c("A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ A * exp(-B * (", x, " - C)^2)"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_lorentz <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ I + A / (1 + B * (", x, " - C) ^ 2)"))
  } else {
    total_pars <- c("A", "B", "C")
    model_form <- as.formula(paste0(y, " ~ A / (1 + B * (", x, " - C) ^ 2)"))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

.nlme_form_beta <- function(x, y, group, individual, matched_sigma, pars, int) {
  #* `Define parameters and main growth formula`
  if (int) {
    total_pars <- c("I", "A", "B", "C", "D", "E")
    model_form <- as.formula(paste0(
      y, " ~ I + A * (((", x, " - D) / (C - D)) * ((E - ", x,
      ") / (E - C)) ^ ((E - C) / (C - D))) ^ B"
    ))
  } else {
    total_pars <- c("A", "B", "C", "D", "E")
    model_form <- as.formula(paste0(
      y, " ~ A * (((", x, " - D) / (C - D)) * ((E - ", x,
      ") / (E - C)) ^ ((E - C) / (C - D))) ^ B"
    ))
  }
  #* `random effects formula`
  random_form <- as.formula(paste0(paste0(total_pars, collapse = " + "), "~ 1"))
  #* `fixed effects formula`
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (is.null(group) || group == "dummyGroup") {
    pars <- ""
  }
  fixed_form <- lapply(total_pars, function(par) {
    if (par %in% pars) {
      stats::as.formula(paste0(par, " ~ 0 + ", group))
    } else {
      stats::as.formula(paste0(par, " ~ 1"))
    }
  })
  #* `groups formula`
  groups_form <- stats::as.formula(paste0("~", group))
  #* `variance formula`
  weights_form <- .nlme_sigma_form(matched_sigma, x, group)
  #* `correlation formula`
  correlation_form <- nlme::corAR1(0.8, form = as.formula(paste0("~ 1 |", group)))

  formulas <- list(
    "model" = model_form, "random" = random_form,
    "fixed" = fixed_form, "groups" = groups_form,
    "weights" = weights_form, "cor_form" = correlation_form, "pars" = pars
  )
  return(formulas)
}

#' Check priors used in ease of use brms functions
#'
#' @param priors A named list of means for prior distributions.
#' This takes the same input as the prior argument of \code{\link{growthSS}}.
#' Alternatively, if given the output of growthSS this will preform a prior predictive check
#' and return a plot from \code{\link{growthPlot}} of that check ignoring all other arguments.
#' Note that all priors must be
#' proper in that case (non-flat) and the fit is likely to be strange looking due to how thick
#' tailed the default priors from \code{\link{growthSS}} are.
#' @param type Either "density", the default, or a model as would be specified in \code{growthSS}
#' or \code{growthSim} such as "logistic", "gompertz", "monomolecular", "exponential",
#' "linear", "power law", "double logistic", or "double gompertz".
#' If this is a model type then n draws from the prior will be simulated as growth
#' trendlines and densities will be plotted on margins for some distributions.
#' @param n Numeric, if type is a model then how many draws from the prior should be simulated?
#' @param t Numeric, time passed to growthSim. Defaults to 25 (the growthSim default).
#' @keywords Bayesian brms priors
#' @return A named list of plots showing prior distributions that \code{growthSS} would use,
#' optionally with a plot of simulated growth curves using draws from those priors.
#' @import ggplot2
#' @import patchwork
#' @importFrom stats rlnorm dlnorm
#' @examples
#'
#' set.seed(123)
#' priors <- list("A" = c(100, 130), "B" = c(10, 8), "C" = c(0.2, 0.1))
#' plotPrior(priors)
#'
#' plotPrior(priors, "gompertz")[[1]]
#'
#' @export

plotPrior <- function(priors, type = "density", n = 200, t = 25) {
  if ("prior" %in% names(priors)) {
    p <- .brms_prior_predictive(priors)
    return(p)
  }
  densPlots <- lapply(seq_along(priors), function(i) {
    pri <- priors[[i]]
    nm <- names(priors)[i]

    pri_df <- do.call(rbind, lapply(seq_along(pri), function(o) {
      prio <- pri[o]
      max <- ceiling(max(rlnorm(1000, log(max(pri)), 0.25)) * 1.1)
      support <- seq(0, max, length.out = 10000)
      dens <- dlnorm(support, meanlog = log(prio), sdlog = 0.25)
      pdf <- dens / sum(dens)
      data.frame(
        support = support,
        dens = pdf,
        param = nm,
        item = as.character(o)
      )
    }))

    ggplot2::ggplot(pri_df, ggplot2::aes(
      x = .data$support, y = .data$dens,
      fill = .data$item, group = .data$item
    )) +
      ggplot2::geom_polygon(alpha = 0.5) +
      ggplot2::theme_minimal() +
      ggplot2::labs(y = "Density", title = nm, fill = "Prior")
  })
  names(densPlots) <- names(priors)

  if (type == "density") {
    out <- densPlots
  } else {
    simdf <- do.call(rbind, lapply(1:n, function(i) {
      iter_params <- .prior_sampler(priors)
      x <- growthSim(model = type, n = 1, t = t, params = iter_params)
      x$id <- paste0("id_", i)
      x
    }))

    model_plot <- ggplot2::ggplot(
      simdf,
      ggplot2::aes(
        x = .data$time, y = .data$y, group = interaction(.data$id, .data$group),
        color = .data$group
      )
    ) +
      ggplot2::geom_line(linewidth = 0.1) +
      ggplot2::theme_minimal() +
      ggplot2::guides(color = ggplot2::guide_legend(override.aes = list(linewidth = 5))) +
      ggplot2::labs(
        y = "Y", title = paste0(n, " curves simulated from prior draws"),
        color = "Prior"
      ) +
      ggplot2::theme(
        legend.position = "inside",
        legend.position.inside = c(0.9, 0.9)
      )

    if (type %in% c("logistic", "gompertz", "weibull", "frechet", "gumbel")) {
      x <- "B"
      y <- "A"
      z <- "C"
    } else if (type %in% c("monomolecular")) {
      y <- "A"
      x <- z <- NULL
    } else {
      x <- y <- z <- NULL
    }
    out <- .plotPriorMarginPlots(model_plot, densPlots, x, y, z)
  }

  return(out)
}

#' @description
#' Internal function for adding marginal plots to plotPrior
#' @keywords internal
#' @noRd

.plotPriorMarginPlots <- function(model_plot, densPlots, x, y, z) {
  xLims <- ggplot2::layer_scales(model_plot)$x$range$range
  yLims <- ggplot2::layer_scales(model_plot)$y$range$range
  model_plot_solo <- model_plot

  sum_non_null <- 0
  x_margin_plot <- NULL
  y_margin_plot <- NULL
  z_margin_plot <- NULL

  if (!is.null(y)) {
    y_margin_plot <- densPlots[[y]] +
      ggplot2::scale_y_reverse(position = "right") +
      ggplot2::scale_x_continuous(position = "top", limits = yLims) +
      ggplot2::labs(x = "Asymptote Prior") +
      ggplot2::coord_flip() +
      ggplot2::theme(
        plot.title = ggplot2::element_blank(), panel.grid = ggplot2::element_blank(),
        axis.text = ggplot2::element_blank(), axis.title.x = ggplot2::element_blank(),
        legend.position = "none"
      )
    sum_non_null <- sum_non_null + 1
  }

  if (!is.null(x)) {
    x_margin_plot <- densPlots[[x]] +
      ggplot2::labs(x = "Inflection Point Prior") +
      ggplot2::theme(
        plot.title = ggplot2::element_blank(), panel.grid = ggplot2::element_blank(),
        axis.text.y = ggplot2::element_blank(), axis.title.y = ggplot2::element_blank(),
        legend.position = "none"
      ) +
      ggplot2::coord_cartesian(xlim = xLims)
    sum_non_null <- sum_non_null + 1
  }

  if (!is.null(z)) {
    z_margin_plot <- densPlots[[z]] +
      ggplot2::labs(x = "Growth Rate Prior") +
      ggplot2::theme(
        plot.title = ggplot2::element_blank(), panel.grid = ggplot2::element_blank(),
        axis.text.y = ggplot2::element_blank(), axis.title.y = ggplot2::element_blank(),
        legend.position = "none"
      ) +
      ggplot2::scale_x_continuous(n.breaks = 3)
    sum_non_null <- sum_non_null + 1
  }

  if (sum_non_null == 3) {
    design <- c(
      patchwork::area(1, 1, 6, 6), # model plot
      patchwork::area(7, 1, 7, 6), # x margin
      patchwork::area(1, 7, 6, 7), # y margin
      patchwork::area(7, 7, 7, 7)
    ) # "z" margin
    layout <- patchwork::plot_layout(design = design)
    model_plot <- model_plot + x_margin_plot + y_margin_plot + z_margin_plot + layout
  } else if (!is.null(y_margin_plot) && is.null(x_margin_plot)) {
    design <- c(
      patchwork::area(1, 1, 6, 6), # model plot
      patchwork::area(1, 7, 6, 7)
    ) # y margin
    model_plot <- model_plot + y_margin_plot + patchwork::plot_layout(design = design)
  }

  if (is(model_plot, "patchwork")) {
    densPlots[[length(densPlots) + 1]] <- model_plot_solo
  }
  return(list("simulated" = model_plot, "distributions" = densPlots))
}




#' @description
#' Internal function for drawing from priors
#' @param priors priors as a list
#' @keywords internal
#' @noRd

.prior_sampler <- function(priors) {
  lapply(priors, function(pri) { # draw sample from prior
    unlist(lapply(pri, function(mu) {
      rlnorm(1, log(mu), 0.25)
    }))
  })
}

#' @description
#' Internal function for sampling a growthSS model's priors only
#' @param priors a list returned by growthSS
#' @keywords internal
#' @noRd

.brms_prior_predictive <- function(priors = NULL) {
  dp <- brms::get_prior(priors$formula, priors$df, priors$family)
  ssp <- priors$prior
  dpi <- as.character(interaction(dp$coef, dp$dpar, dp$nlpar))
  sspi <- as.character(interaction(ssp$coef, ssp$dpar, ssp$nlpar))
  priors$prior <- rbind(ssp, dp[-which(dpi %in% sspi), ])
  tryCatch(
    {
      m <- suppressMessages(
        fitGrowth(priors,
          iter = 1000,
          chains = 1,
          cores = 1,
          sample_prior = "only",
          silent = 2
        )
      )
    },
    error = function(err) {
      message(paste0(
        "Error trying to sample from priors distributions.",
        "All priors must be proper (non-flat). Check prior specification in growthSS\n"
      ))
      message("The original Error message is:")
      stop(conditionMessage(err))
    }
  )
  p <- growthPlot(m, form = priors$pcvrForm, df = priors$df)
  return(p)
}

#' @description
#' Internal function for calculating \alpha and \beta of the gamma distributed variance of lognormal
#' data given an estimate of the lognormal \mu obtained via the method of moments using multi value
#' traits.
#' @param s1 A data.frame or matrix of multi value traits. The column names should include a number
#' representing the "bin".
#'
#' @examples
#' mv_ln <- mvSim(
#'   dists = list(
#'     rlnorm = list(meanlog = log(130), sdlog = log(1.2))
#'   ),
#'   n_samples = 30
#' )
#' .conj_lognormal2_mv(
#'   s1 = mv_ln[, -1],
#'   priors = NULL
#'   plot = FALSE,
#'   cred.int.level = 0.89,
#' )
#' @keywords internal
#' @noRd

.conj_lognormal2_mv <- function(s1 = NULL, priors = NULL,
                                plot = FALSE, support = NULL, cred.int.level = NULL,
                                calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(a = 1, b = 1) # prior on shape, scale of precision
  }
  #* `Reorder columns if they are not in the numeric order`
  histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
  bins_order <- sort(histColsBin, index.return = TRUE)$ix
  s1 <- s1[, bins_order]
  #* `Loop over reps, get moments for each histogram`
  rep_distributions <- lapply(seq_len(nrow(s1)), function(i) {
    X1 <- rep(histColsBin[bins_order], as.numeric(s1[i, ]))
    #* `Get mean of x1`
    x_bar <- mean(X1)
    mu_s1 <- log(x_bar / (sqrt(var(X1) / x_bar^2) + 1))
    #* `Update Gamma Distribution of precision`
    #* sufficient stats: n, ss
    ss <- nrow(s1) * mean((log(X1) - mu_s1)^2) # mean * nrow instead of sum for MV traits
    n1 <- nrow(s1)
    a_prime <- priors$a[1] + (n1 / 2)
    b_prime <- priors$b[1] + (ss / 2)
    return(list("a_prime" = a_prime, "b_prime" = b_prime, "ln_mu" = mu_s1))
  })
  #* `Unlist parameters`
  a_prime <- mean(unlist(lapply(rep_distributions, function(i) {
    i$a_prime
  })))
  b_prime <- mean(unlist(lapply(rep_distributions, function(i) {
    i$b_prime
  })))
  ln_mu_prime <- mean(unlist(lapply(rep_distributions, function(i) {
    i$ln_mu
  })))
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qgamma(c(0.0001, 0.9999), shape = a_prime, scale = b_prime)
    return(quantiles)
  }
  #* `posterior`
  dens1 <- dgamma(support, shape = a_prime, scale = b_prime)
  pdf1 <- dens1 / sum(dens1)
  hde1 <- .gammaHDE(shape = a_prime, scale = b_prime)
  hdi1 <- qgamma(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    shape = a_prime, scale = b_prime
  )
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior$a <- a_prime
  out$posterior$b <- b_prime
  out$posterior$lognormal_mu <- ln_mu_prime # returning this as a number, not a distribution
  #* `Make Posterior Draws`
  out$posteriorDraws <- rgamma(10000, shape = a_prime, scale = b_prime)
  out$pdf <- pdf1
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}



#' @description
#' Internal function for calculating \alpha and \beta of the gamma distributed precision of lognormal
#' data given an estimate of the lognormal \mu obtained via the method of moments using single value
#' traits.
#'
#' @param s1 A vector of numerics drawn from a gaussian distribution.
#' @examples
#' .conj_lognormal2_sv(
#'   s1 = rlnorm(100, log(130), log(1.3)),
#'   priors = NULL,
#'   plot = FALSE,
#'   cred.int.level = 0.89
#' )
#' @keywords internal
#' @noRd

.conj_lognormal2_sv <- function(s1 = NULL, priors = NULL,
                                plot = FALSE, support = NULL, cred.int.level = NULL,
                                calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(a = 1, b = 1) # prior on shape, scale of precision
  }
  #* `Get mean of s1`
  x_bar <- mean(s1)
  mu_s1 <- log(x_bar / (sqrt(var(s1) / x_bar^2) + 1))
  #* `Update Gamma Distribution of precision`
  #* sufficient stats: n, ss
  ss <- sum((log(s1) - mu_s1)^2)
  n1 <- length(s1)
  a_prime <- priors$a[1] + (n1 / 2)
  b_prime <- priors$b[1] + (ss / 2)
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qgamma(c(0.0001, 0.9999), shape = a_prime, scale = b_prime)
    return(quantiles)
  }
  #* `posterior`
  dens1 <- dgamma(support, shape = a_prime, scale = b_prime)
  pdf1 <- dens1 / sum(dens1)
  hde1 <- .gammaHDE(shape = a_prime, scale = b_prime)
  hdi1 <- qgamma(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    shape = a_prime, scale = b_prime
  )
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior$a <- a_prime
  out$posterior$b <- b_prime
  out$posterior$lognormal_mu <- mu_s1 # returning this as a number, not a distribution
  #* `Make Posterior Draws`
  out$posteriorDraws <- rgamma(10000, shape = a_prime, scale = b_prime)
  out$pdf <- pdf1
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' Hypothesis testing for \link{fitGrowth} models.
#'
#' @param ss A list output from \link{growthSS}. This is not required for nls, nlme, and brms models
#' if \code{test} is given in \code{brms::hypothesis} style as a written statement.
#' @param fit A model (or list of nlrq models) output from \link{fitGrowth}.
#' @param test A description of the hypothesis to test. This can take two main forms,
#' either the parameter names to vary before comparing a nested model ("A", "B", "C") using an anova
#' or a hypothesis test/list of hypothesis tests written as character strings.
#' The latter method is not implemented for \code{nlrq} models. If this is a vector of parameters
#' to test in the model then they should be parameters which vary by group in your original model
#' and that you want to test against a null model where they do not vary by group.
#' Alternatively for nlrq models this can be a comparison of model terms
#' written as \code{"group_X|tau|par - group_Y|tau|par"}, which uses a fat tailed T distribution to make
#' comparisons on the means of each quantile estimate. For GAMs these tests compare the model with
#' splines either by group or interacting with group to a model that ignores the grouping in the data.
#' If this is a list of hypothesis tests then they should describe tests similar to
#' "A.group1 - A.group2*1.1" and can be thought of as contrasts. For brms models the "test" argument
#' is passed to brms::hypothesis, which has extensive documentation and is very flexible.
#' Note that for survreg the \code{survival::survdiff} function is used so fewer hypothesis testing
#' options are available and flexsurv models are tested using contrasts via \code{flexsurv::standsurv}.
#' @keywords hypothesis brms nlme nls nlrq mgcv
#' @importFrom stats getCall logLik pchisq anova as.formula setNames vcov coef pt
#' @importFrom nlme pdIdent corAR1 fixef
#' @importFrom extraDistr qlst dlst
#' @importFrom methods is
#' @importFrom car deltaMethod
#' @importFrom survival survdiff
#'
#' @details
#' For nls and nlme models an anova is run and returned as part of a list along with the null model.
#'  For nlrq models several assumptions are made and a likelihood ratio test for each tau
#'  is run and returned as a list.
#'
#'
#' @return A list containing an anova object comparing non-linear growth models and the null model.
#'
#' @examples
#'
#' set.seed(123)
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- suppressMessages(growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   df = simdf, type = "nlrq"
#' ))
#' fit <- fitGrowth(ss)
#' testGrowth(ss, fit, "A")
#' testGrowth(ss, fit, "a|0.5|A > b|0.5|A")
#'
#' ss2 <- suppressMessages(growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   df = simdf, type = "nls"
#' ))
#' fit2 <- fitGrowth(ss2)
#' testGrowth(ss2, fit2, "A")$anova
#' coef(fit2) # check options for contrast testing
#' testGrowth(ss2, fit2, "A1 - A2*1.1")
#'
#' @export

testGrowth <- function(ss = NULL, fit, test = "A") {
  method <- .specifyTestType(ss, test)
  if (method == "contrast") {
    res <- .nlhypothesis(fit, test, ss)
  } else if (method == "anova") {
    if (ss$model == "gam") {
      #* do gam things
      if (ss$type == "nls") {
        res <- .lmGamAnova(ss, fit)
      } else if (ss$type == "nlrq") {
        res <- .rqGamAnova(ss, fit)
      } else if (ss$type == "nlme") {
        res <- .lmeGamAnova(ss, fit)
      } else if (ss$type == "mgcv") {
        res <- .mgcvGamAnova(ss, fit)
      }
    } else if (ss$type %in% c("nls", "nlme")) {
      res <- .nlsAnova(ss, fit, test_pars = test)
    } else if (ss$type == "nlrq") {
      if (any(test %in% c("A", "B", "C"))) {
        res <- .nlrqTest(ss, fit, test_pars = test)
      }
    } else if (grepl("surv", ss$type)) {
      res <- .survTest(ss)
    }
  }

  return(res)
}

#' Helper function to specify type of testing to do
#' @examples
#' .specifyTestType(NULL, "anything") # survival test
#' .specifyTestType(list(), "A") # parameter anova test
#' .specifyTestType(list(), "A1 > A2") # contrast test
#' @keywords internal
#' @noRd

.specifyTestType <- function(ss, test) {
  if (!is.null(ss) && grepl("surv", ss$type)) {
    test <- "S"
  }
  if (all(unlist(lapply(test, nchar)) <= 2)) {
    method <- "anova"
  } else {
    method <- "contrast"
  }
  return(method)
}

#' (non)linear hypothesis function for nls and nlme models
#' @examples
#'
#' logistic_df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   df = logistic_df, type = "nls"
#' )
#' fit <- fitGrowth(ss)
#' .nlhypothesis(fit, test = list("A1 - A2", "B1-B2"))
#' .nlhypothesis(fit, test = "A1 + 10 - A2 * 1.1")
#' .nlhypothesis(fit, test = "A1/B1 - A2/B2")
#'
#' @keywords internal
#' @noRd

.nlhypothesis <- function(fit, test, ss) {
  if (methods::is(fit, "nlme")) {
    coefs <- nlme::fixef(fit)
  } else if (methods::is(fit, "nls")) {
    coefs <- stats::coef(fit)
  } else if (methods::is(fit, "brmsfit")) {
    out <- brms::hypothesis(fit, test)
    return(out)
  } else if (methods::is(fit, "nlrq") || is.list(fit)) {
    out <- .nlrqTest2(ss, fit, test)
    return(out)
  }
  dfresid <- summary(fit)$df[2]
  vcMat <- stats::vcov(fit)
  hypotheses <- data.frame(form = unlist(test))
  colnames(hypotheses) <- c("Form")
  val <- do.call(rbind, lapply(seq_len(nrow(hypotheses)), function(i) {
    car::deltaMethod(
      object = coefs, g = as.character(hypotheses$Form[i]),
      vcov. = vcMat, level = 0.95
    )
  }))
  row.names(val) <- seq_len(nrow(hypotheses))
  val <- cbind(hypotheses, val)
  lenVal <- ncol(val)
  out <- val[, 1:(lenVal - 2)]
  out$"t-value" <- abs(out$Estimate / out$SE)
  residualDF <- ifelse(is.null(dfresid), Inf, dfresid)
  out$"p-value" <- 2 * pt(out$"t-value", residualDF, lower.tail = FALSE)
  if (residualDF == Inf) colnames(out)[length(colnames(out)) - 1] <- "Z-value"
  return(out)
}



#' mgcv gam testing function
#' @examples
#'
#' logistic_df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "gam", form = y ~ time | id / group,
#'   df = logistic_df, type = "mgcv"
#' )
#' fit <- fitGrowth(ss)
#' .mgcvGamAnova(ss, fit)$anova
#'
#' @keywords internal
#' @noRd

.mgcvGamAnova <- function(ss, fit) {
  #* `Get x variable`
  RHS <- as.character(ss$formula)[3]
  x <- sub(",", "", sub("s\\(", "", regmatches(RHS, regexpr("s\\(.*,", RHS))))
  ssNew <- ss
  #* ***** `Make Null formula`
  ssNew$formula <- stats::as.formula(paste0("y ~ s(", x, ")"))
  #* `rerun fitGrowth with new formula`
  nullMod <- fitGrowth(ssNew)
  #* `compare models and return values`
  anv <- stats::anova(nullMod, fit, test = "F")
  out <- list("anova" = anv, "nullMod" = nullMod)
  return(out)
}



#' lme gam testing function
#' @examples
#'
#' logistic_df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "gam", form = y ~ time | id / group,
#'   df = logistic_df, type = "nlme"
#' )
#' fit <- fitGrowth(ss)
#' .lmeGamAnova(ss, fit)$anova
#'
#' @keywords internal
#' @noRd

.lmeGamAnova <- function(ss, fit) {
  #* `Get x variable`
  x <- trimws(sub("\\*.*", "", as.character(ss$formula$model)[3]))
  ssNew <- ss
  #* ***** `Make Null formulas`
  newdf <- ss$df
  newdf$dummy <- "A"
  model_form <- ss$formula$model # fixed effects should be constant for likelihood testing
  #* random effects formula
  random_form <- stats::setNames(list(nlme::pdIdent(~ splines - 1, data = newdf)), "dummy")
  #* variance formula
  weights_form <- .nlme_sigma_form(as.list(ss$call)$sigma, x, "dummy")
  #* correlation formula
  correlation_form <- nlme::corAR1(0.8, form = stats::as.formula(paste0("~ 1 | dummy")))
  #* add all to newSS as list
  ssNew$formula <- list(
    "model" = model_form, "random" = random_form,
    "weights" = weights_form, "cor_form" = correlation_form
  )
  ssNew$df <- newdf
  #* `rerun fitGrowth with new formula`
  nullMod <- fitGrowth(ssNew)
  #* `compare models and return values`
  anv <- stats::anova(nullMod, fit)
  out <- list("anova" = anv, "nullMod" = nullMod)
  return(out)
}


#' rq gam testing function for multiple taus
#' @examples
#'
#' logistic_df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "gam", form = y ~ time | id / group,
#'   df = logistic_df, type = "nlrq", tau = c(0.25, 0.5, 0.75)
#' )
#' fit <- fitGrowth(ss, cores = 3)
#' .rqGamAnova(ss, fit)$"0.25"$anova
#' .rqGamAnova(ss, fit[[1]])$anova
#'
#' @keywords internal
#' @noRd

.rqGamAnova <- function(ss, fit) {
  if (methods::is(fit, "rq")) {
    tau <- as.character(fit$tau)
    fit <- stats::setNames(list(fit), tau)
  }
  taus <- names(fit)
  res <- lapply(taus, function(tau) {
    f <- fit[[tau]]
    #* `remove grouping from ss$formula`
    rhs <- as.character(ss$formula)[3]
    newRhs <- trimws(sub("\\*.*", "", rhs))
    newFormula <- stats::as.formula(paste0(as.character(ss$formula)[2], "~", newRhs))
    #* `Make new SS object`
    ssNew <- ss
    ssNew$formula <- newFormula
    ssNew$taus <- as.numeric(tau)
    #* `rerun fitGrowth with new formula`
    nullMod <- fitGrowth(ssNew)
    #* `compare models and return values`
    anv <- stats::anova(nullMod, f)
    out <- list("anova" = anv, "nullMod" = nullMod)
    return(out)
  })
  names(res) <- taus
  if (length(res) == 1) {
    res <- res[[1]]
  }
  return(res)
}

#' lm gam testing function
#' @examples
#'
#' logistic_df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "gam", form = y ~ time | id / group,
#'   df = logistic_df, type = "nls"
#' )
#' fit <- fitGrowth(ss)
#' .lmGamAnova(ss, fit)$anova
#'
#' @keywords internal
#' @noRd

.lmGamAnova <- function(ss, fit) {
  #* `remove grouping from ss$formula`
  rhs <- as.character(ss$formula)[3]
  newRhs <- trimws(sub("\\*.*", "", rhs))
  newFormula <- stats::as.formula(paste0(as.character(ss$formula)[2], "~", newRhs))
  #* `Make new SS object`
  ssNew <- ss
  ssNew$formula <- newFormula
  #* `rerun fitGrowth with new formula`
  nullMod <- fitGrowth(ssNew)
  #* `compare models and return values`
  anv <- stats::anova(nullMod, fit)
  out <- list("anova" = anv, "nullMod" = nullMod)
  return(out)
}


#' nls and nlme testing function
#' @examples
#'
#' logistic_df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   df = logistic_df, type = "nls"
#' )
#' fit <- fitGrowth(ss)
#' .nlsAnova(ss, fit, test_pars = "A")$anova
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   df = logistic_df, type = "nlme"
#' )
#' fit <- fitGrowth(ss)
#' .nlsAnova(ss, fit, test_pars = "A")$anova
#'
#' @keywords internal
#' @noRd

.nlsAnova <- function(ss, fit, test_pars = "A") {
  #* `Get parameters to vary in comparison model`
  xForm <- as.character(ss$formula)[3]
  rMatches <- gregexpr(".2?\\[", xForm)
  original_grouped_pars <- sub("\\[", "", regmatches(xForm, rMatches)[[1]])
  null_pars <- original_grouped_pars[!original_grouped_pars %in% test_pars]
  #* `match call for previous model, updating pars`
  lcall <- as.list(ss$call)
  lcall$pars <- null_pars
  lcall$df <- ss$df
  new_call <- as.call(lcall)
  #* `rerun growthSS and fitGrowth with updated parameters`
  nullSS <- suppressMessages(eval(new_call))
  nullMod <- fitGrowth(nullSS)
  #* `compare models and return values`
  anv <- stats::anova(nullMod, fit)
  out <- list("anova" = anv, "nullMod" = nullMod)
  return(out)
}

#' pseudo LRT function for nlrq
#' @examples
#'
#' logistic_df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   df = logistic_df, type = "nlrq", tau = c(0.25, 0.5, 0.75)
#' )
#' fit <- fitGrowth(ss)
#' .nlrqTest(ss, fit, test_pars = "A")$anova
#'
#' @keywords internal
#' @noRd

.nlrqTest <- function(ss, fit, test_pars = "A") {
  #* `Get parameters to vary in comparison model`
  xForm <- as.character(ss$formula)[3]
  rMatches <- gregexpr(".2?\\[", xForm)
  original_grouped_pars <- sub("\\[", "", regmatches(xForm, rMatches)[[1]])
  null_pars <- original_grouped_pars[!original_grouped_pars %in% test_pars]
  #* `match call for previous model, updating pars`
  lcall <- as.list(ss$call)
  lcall$pars <- null_pars
  lcall$df <- ss$df
  new_call <- as.call(lcall)
  #* `rerun growthSS and fitGrowth with updated parameters`
  nullSS <- suppressMessages(eval(new_call))
  nullMods <- fitGrowth(nullSS)
  if (methods::is(fit, "nlrq")) {
    fit <- list(fit)
    names(fit) <- ss$taus
    nullMods <- list(nullMods)
    names(nullMods) <- ss$taus
  }

  #* `arrange models for comparisons`

  modsList <- lapply(ss$taus, function(tau) list(fit[[paste0(tau)]], nullMods[[paste0(tau)]]))

  res <- lapply(modsList, function(modsPair) {
    .nlrqPseudoLRT(modsPair)
  })
  names(res) <- ss$taus
  return(res)
}


#' pseudo LRT function for nlrq, aiming to use empirical likelihood given more time
#' @param nested_models list of models with the same tau generated by .nlrqTest
#' @keywords internal
#' @noRd

.nlrqPseudoLRT <- function(nested_models) {
  nModels <- length(nested_models) # currently always 2, but might change in the future.
  rval <- matrix(rep(NA, 5 * 2), ncol = 5)
  colnames(rval) <- c("#Df", "LogLik", "Df", "Chisq", "Pr(>Chisq)")
  rownames(rval) <- 1:2
  logL <- lapply(nested_models, stats::logLik)
  rval[, 1] <- as.numeric(sapply(logL, function(x) attr(x, "df")))
  rval[, 2] <- sapply(logL, as.numeric)
  rval[2:nModels, 3] <- rval[2:nModels, 1] - rval[1:(nModels - 1), 1]
  rval[2:nModels, 4] <- 2 * abs(rval[2:nModels, 2] - rval[1:(nModels - 1), 2])
  rval[, 5] <- stats::pchisq(rval[, 4], round(abs(rval[, 3])), lower.tail = FALSE)

  variables <- lapply(nested_models, function(x) {
    deparse(as.list(stats::getCall(x))$formula)
  })
  header <- paste("Model ", format(1:nModels), ": ", variables, sep = "", collapse = "\n")
  out <- structure(as.data.frame(rval),
    heading = header,
    class = c("anova", "data.frame")
  )
  return(out)
}


#' Parameterized test for nlrq models using SE
#' @examples
#' logistic_df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   df = logistic_df, type = "nlrq", tau = c(0.25, 0.5, 0.75)
#' )
#' fit <- fitGrowth(ss)
#' .nlrqTest2(ss, fit, test_pars = "a|0.5|A > b|0.5|A")
#' @keywords internal
#' @noRd

.nlrqTest2 <- function(ss, fit, test_pars = "a|0.5|A > b|0.5|A") {
  #* `Get parameters to vary in comparison model`
  xForm <- as.character(ss$formula)[3]
  #* `Get name of grouping variable in formula`
  rMatches2 <- regexpr("\\[[a-zA-Z0-9.]*\\]", xForm)
  groupVar <- sub("\\]", "", sub("\\[", "", regmatches(xForm, rMatches2)))
  #* `parse test_pars formula`
  split_form <- lapply(strsplit(test_pars, ">|<")[[1]], function(s) {
    stats::setNames(strsplit(trimws(s), "\\|")[[1]], c("group", "tau", "par"))
  })
  direction <- ifelse(grepl(">", test_pars), "greater", "lesser")
  #* `select models based on tau`
  if (!methods::is(fit, "nlrq")) {
    fit1 <- fit[[split_form[[1]]["tau"]]]
    fit2 <- fit[[split_form[[2]]["tau"]]]
    fits <- list(fit1, fit2)
  } else {
    fits <- list(fit, fit)
  }
  #* `get model data for each group in formula`
  mdf <- do.call(rbind, lapply(seq_along(split_form), function(i) {
    sf <- split_form[[i]]
    #* `get model parameters`
    mdf <- as.data.frame(summary(fits[[i]])$coefficients)
    #* `replace 1-nGroups with sorted group names`
    mdf$par <- substr(rownames(mdf), 1, 1)
    mdf$numericGroup <- sub("^[A-C]", "", rownames(mdf))

    gNames <- stats::setNames(
      data.frame(sort(unique(ss$df[[groupVar]])), seq_along(unique(ss$df[[groupVar]]))),
      c(groupVar, "numericGroup")
    )
    mdf <- merge(mdf, gNames, by = "numericGroup")
    return(mdf[
      mdf[[groupVar]] == sf[["group"]] & mdf[["par"]] == sf[["par"]],
      c("Value", "Std. Error", "t value", "Pr(>|t|)", "par", "group")
    ])
  }))
  #* `make T distributions for comparisons`
  support1 <- extraDistr::qlst(c(0.0001, 0.9999),
    df = 5, mu = mdf[1, "Value"],
    sigma = mdf[1, "Std. Error"]
  )
  support2 <- extraDistr::qlst(c(0.0001, 0.9999),
    df = 5, mu = mdf[2, "Value"],
    sigma = mdf[2, "Std. Error"]
  )
  mn <- 0.99 * min(c(support1, support2))
  mx <- 1.01 * max(c(support1, support2))
  support <- seq(mn, mx, length.out = 10000)
  t1 <- extraDistr::dlst(support, df = 5, mu = mdf[1, "Value"], sigma = mdf[1, "Std. Error"])
  t2 <- extraDistr::dlst(support, df = 5, mu = mdf[2, "Value"], sigma = mdf[2, "Std. Error"])
  pdf1 <- t1 / sum(t1)
  pdf2 <- t2 / sum(t2)
  res <- .post.prob.from.pdfs(pdf1, pdf2, direction)$post.prob
  mdf[[paste0("prob.", direction)]] <- c(res, NA)
  return(mdf)
}


#' Chisq based test for survreg and flexsurv models using SE
#' @examples
#'
#'
#' df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS("survival weibull", y > 100 ~ time | id / group, df = df, type = "survreg")
#' fit <- fitGrowth(ss)
#' .survTest(ss, fit)
#'
#' ss <- growthSS("survival weibull", y > 100 ~ time | id / group, df = df, type = "flexsurv")
#' fit <- fitGrowth(ss)
#' .survTest(ss, fit)
#'
#' @keywords internal
#' @noRd

.survTest <- function(ss = NULL, fit = NULL) {
  if (ss$type == "survreg") {
    survival::survdiff(formula = ss$formula, data = ss$df)
  } else if (ss$type == "flexsurv") {
    x <- as.character(ss$pcvrForm)[3]
    x3 <- trimws(strsplit(x, "[|]|[/]")[[1]])
    group <- x3[length(x3)]
    groups <- unique(ss$df[[group]])
    at <- lapply(groups, function(i) stats::setNames(list(i), group))
    as.data.frame(flexsurv::standsurv(fit, at = at, contrast = "difference", se = TRUE, ci = TRUE))
  }
}

#' Function to visualize \code{quantreg::rq} general additive growth models.
#'
#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
#' (and similar models made through other means) can be visualized easily using this function.
#' This will generally be called by \code{growthPlot}.
#'
#' @param fit A model fit, or list of model fits, returned by \code{fitGrowth}
#' with type="nlrq" and model="gam".
#' @param form A formula similar to that in \code{growthSS} inputs (or the \code{pcvrForm}
#' part of the output) specifying the outcome,
#' predictor, and grouping structure of the data as \code{outcome ~ predictor|individual/group}.
#' If the individual and group are specified then the observed growth lines are plotted.
#' @param df A dataframe to use in plotting observed growth curves on top of the model.
#' This must be supplied for rq models.
#' @param groups An optional set of groups to keep in the plot.
#' Defaults to NULL in which case all groups in the model are plotted.
#' @param timeRange An optional range of times to use. This can be used to view predictions for
#' future data if the avaiable data has not reached some point (such as asymptotic size).
#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
#' @param groupFill logical, should groups have different colors? Defaults to FALSE.
#' If TRUE then viridis colormaps are used in the order of virMaps
#' @param virMaps order of viridis maps to use. Will be recycled to necessary length.
#' Defaults to "plasma", but will generally be informed by growthPlot's default.
#' @keywords growth-curve
#' @importFrom methods is
#' @import ggplot2
#' @importFrom stats setNames predict
#' @importFrom viridis plasma
#' @examples
#'
#'
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "gam", form = y ~ time | id / group,
#'   tau = c(0.25, 0.5, 0.75), df = simdf, start = NULL, type = "nlrq"
#' )
#' fits <- fitGrowth(ss)
#' rqPlot(fits, form = ss$pcvrForm, df = ss$df, groupFill = TRUE)
#' rqPlot(fits, form = ss$pcvrForm, df = ss$df, groups = "a", timeRange = 1:10)
#'
#' ss <- growthSS(
#'   model = "gam", form = y ~ time | group,
#'   tau = c(0.5), df = simdf, start = NULL, type = "nlrq"
#' )
#' fit <- fitGrowth(ss)
#' rqPlot(fit, form = ss$pcvrForm, df = ss$df, groupFill = TRUE)
#'
#' @return Returns a ggplot showing an rq general additive model's quantiles
#'  and optionally the individual growth lines.
#'
#' @export

rqPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE,
                   groupFill = FALSE, virMaps = c("plasma")) {
  #* `get needed information from formula`
  parsed_form <- .parsePcvrForm(form, df)
  #* `pick longitudinal or non-longitudinal helper`
  if (!is.numeric(df[, parsed_form$x]) && !parsed_form$USEG && !parsed_form$USEID) {
    p <- .rqStaticPlot(
      fit, form, df, groups, timeRange,
      facetGroups, groupFill, virMaps, parsed_form
    )
    return(p)
  }
  p <- .rqLongitudinalPlot(
    fit, form, df, groups, timeRange,
    facetGroups, groupFill, virMaps, parsed_form
  )
  return(p)
}

#' @keywords internal
#' @noRd

.rqStaticPlot <- function(fit, form, df, groups, timeRange,
                          facetGroups, groupFill, virMaps, parsed_form) {
  x <- parsed_form$x
  df <- parsed_form$data

  if (methods::is(fit, "rq")) {
    fit <- list(fit)
  }

  summary_df <- do.call(rbind, lapply(fit, function(model) {
    iter_df <- as.data.frame(coef(summary(model)))
    colnames(iter_df) <- c("est", "err", "t", "p")
    iter_df[[x]] <- rownames(iter_df)
    iter_df[1, x] <- paste0(x, unique(df[[x]])[1])
    iter_df[["est"]] <- cumsum(iter_df[["est"]])
    iter_df$tau <- model$tau
    iter_df
  }))

  #* `filter by groups if groups != NULL`
  if (!is.null(groups)) {
    summary_df <- summary_df[summary_df[[x]] %in% groups, ]
  }
  #* `facetGroups`
  facet_layer <- NULL
  if (facetGroups) {
    facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", x)),
      scales = "free_x"
    )
  }
  #* `groupFill`
  n_taus <- length(unique(summary_df$tau))
  if (groupFill) {
    virList <- lapply(rep(virMaps, length.out = length(unique(summary_df[[x]]))), function(pal) {
      virpal_p1 <- viridis::viridis(ceiling(n_taus / 2),
        direction = 1, end = 1, option = pal
      )
      virpal_p2 <- viridis::viridis(ceiling(n_taus / 2),
        direction = -1, end = 1, option = pal
      )[-1]
      c(virpal_p1, virpal_p2)
    })
  } else {
    virpal_p1 <- viridis::plasma(ceiling(n_taus / 2), direction = 1, end = 1)
    virpal_p2 <- viridis::plasma(ceiling(n_taus / 2), direction = -1, end = 1)[-1]
    virpal <- c(virpal_p1, virpal_p2)
    virList <- lapply(seq_along(unique(summary_df[[x]])), function(i) {
      virpal
    })
  }
  #* `plot`
  plot <- ggplot(summary_df, ggplot2::aes(group = interaction(.data[[x]]))) +
    facet_layer +
    labs(x = x, y = as.character(form)[2]) +
    pcv_theme()

  for (g in seq_along(unique(summary_df[[x]]))) {
    iteration_group <- unique(summary_df[[x]])[g]
    sub <- summary_df[summary_df[[x]] == iteration_group, ]
    for (i in seq_along(unique(sub$tau))) {
      inner_sub <- sub[sub$tau == unique(sub$tau)[i], ]
      plot <- plot +
        ggplot2::geom_errorbar(data = inner_sub, ggplot2::aes(
          x = .data[[x]],
          ymin = .data[["est"]] - 2 * .data[["err"]],
          ymax = .data[["est"]] + 2 * .data[["err"]]
        ), width = 0.15, color = virList[[g]][i]) +
        ggplot2::geom_point(
          data = inner_sub, ggplot2::aes(
            x = .data[[x]],
            y = .data[["est"]]
          ),
          color = virList[[g]][i], size = 4
        ) +
        ggplot2::geom_text(
          data = inner_sub, ggplot2::aes(
            x = .data[[x]],
            y = .data[["est"]],
            label = .data[["tau"]]
          ),
          size = 2, color = "white"
        )
    }
  }
  plot
  return(plot)
}

#' @keywords internal
#' @noRd

.rqLongitudinalPlot <- function(fit, form, df, groups, timeRange,
                                facetGroups, groupFill, virMaps, parsed_form) {
  y <- parsed_form$y
  x <- parsed_form$x
  individual <- parsed_form$individual
  if (individual == "dummyIndividual") {
    individual <- NULL
  }
  group <- parsed_form$group
  df <- parsed_form$data
  #* `filter by groups if groups != NULL`
  if (!is.null(groups)) {
    df <- df[df[[group]] %in% groups, ]
  }
  #* `make new data if timerange is not NULL`
  if (!is.null(timeRange)) {
    new_data <- do.call(rbind, lapply(unique(df[[group]]), function(g) {
      stats::setNames(data.frame(g, timeRange), c(group, x))
    }))
    df <- df[df[[x]] >= min(timeRange) & df[[x]] <= max(timeRange), ]
  } else {
    new_data <- df
  }
  #* `standardize fit class`
  if (methods::is(fit, "rq")) {
    fit <- list(fit)
    names(fit) <- fit$tau
  }
  #* `add predictions and record taus`
  preds <- do.call(cbind, lapply(fit, function(f) {
    tau <- f$tau
    stats::setNames(data.frame(stats::predict(f, newdata = new_data)), paste0("Q_", tau))
  }))
  predCols <- colnames(preds)
  keep <- which(!duplicated(preds))
  plotdf <- cbind(df[keep, ], preds[keep, ])
  colnames(plotdf) <- c(colnames(df), colnames(preds))
  #* `layer for individual lines if formula was complete`
  individual_lines <- list()
  if (!is.null(individual)) {
    individual_lines <- ggplot2::geom_line(
      data = df, ggplot2::aes(
        x = .data[[x]], y = .data[[y]],
        group = interaction(
          .data[[individual]],
          .data[[group]]
        )
      ),
      linewidth = 0.25, color = "gray40"
    )
  }
  #* `facetGroups`
  facet_layer <- NULL
  if (facetGroups) {
    facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
  }
  #* `groupFill`
  if (groupFill) {
    virList <- lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
      virpal_p1 <- viridis::viridis(ceiling(length(predCols) / 2), direction = 1, end = 1, option = pal)
      virpal_p2 <- viridis::viridis(ceiling(length(predCols) / 2),
        direction = -1, end = 1, option = pal
      )[-1]
      c(virpal_p1, virpal_p2)
    })
  } else {
    virpal_p1 <- viridis::plasma(ceiling(length(predCols) / 2), direction = 1, end = 1)
    virpal_p2 <- viridis::plasma(ceiling(length(predCols) / 2), direction = -1, end = 1)[-1]
    virpal <- c(virpal_p1, virpal_p2)
    virList <- lapply(seq_along(unique(df[[group]])), function(i) {
      virpal
    })
  }
  #* `plot`
  plot <- ggplot(plotdf, ggplot2::aes(group = interaction(.data[[group]]))) +
    facet_layer +
    individual_lines +
    labs(x = x, y = as.character(form)[2]) +
    pcv_theme()

  for (g in seq_along(unique(plotdf[[group]]))) {
    iteration_group <- unique(plotdf[[group]])[g]
    sub <- plotdf[plotdf[[group]] == iteration_group, ]
    plot <- plot +
      lapply(seq_along(predCols), function(i) {
        ggplot2::geom_line(
          data = sub, ggplot2::aes(x = .data[[x]], y = .data[[predCols[i]]]),
          color = virList[[g]][i], linewidth = 0.7
        )
      })
  }
  return(plot)
}

#' Ease of use nlrq/nls starter function for standard growth model parameterizations
#'
#' Internal to growthSS
#'
#' @examples
#'
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#'
#' ss <- .nlrqSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   tau = 0.5, df = simdf, start = NULL
#' )
#' model <- "logistic"
#' form <- y ~ time | id / group
#' tau <- 0.5
#' df <- simdf
#' start <- NULL
#' pars <- NULL
#' ss <- .nlrqSS(model = "gam", form = y ~ time | id / group, df = simdf, start = NULL, tau = 0.5)
#'
#' dim(ss$df)
#' ss[c("formula", "taus", "start", "pcvrForm")]
#' @importFrom splines bs
#' @importFrom stats sortedXyData
#' @keywords internal
#' @noRd

.nlrqSS <- function(model, form, tau = 0.5, df, pars = NULL, start = NULL, type = "nlrq", int = FALSE) {
  #* ***** `Define choices and make empty output list`
  out <- list()
  models <- c(
    "logistic", "gompertz", "monomolecular", "exponential", "linear", "power law",
    "double logistic", "double gompertz", "gam", "frechet", "weibull", "gumbel", "logarithmic",
    "bragg", "lorentz", "beta"
  )
  #* ***** `Make nlrq formula` *****
  #* `parse form argument`
  parsed_form <- .parsePcvrForm(form, df)
  y <- parsed_form$y
  x <- parsed_form$x
  group <- parsed_form$group
  USEGROUP <- parsed_form$USEG
  if (parsed_form$USEID) {
    message(paste0("Individual is not used with type = '", type, "'."))
  }
  df <- parsed_form$data
  if (USEGROUP) {
    df[[group]] <- factor(df[[group]])
    df[[paste0(group, "_numericLabel")]] <- unclass(df[[group]])
  }
  #* `assemble growth formula`
  if (grepl("decay", model)) {
    decay <- TRUE
    model <- trimws(gsub("decay", "", model))
  } else {
    decay <- FALSE
  }

  matched_model <- match.arg(model, models)
  stringFormFun <- paste0(".nlrq_form_", gsub(" ", "", matched_model))
  form_fun <- match.fun(stringFormFun)
  res <- form_fun(x, y, USEGROUP, group, pars, int)
  growthForm <- res[[1]]
  pars <- res[[2]]

  if (decay) {
    growthForm <- .nlrqDecay(growthForm)
  }

  if (matched_model == "gam") {
    start <- 0
  }

  if (is.null(start)) {
    if (grepl("double", matched_model)) {
      warning(paste0(
        "Double Sigmoid models are not supported as self-starting models,",
        " you will need to add starting parameters.",
        " Note for these models type='brms' is recommended."
      ))
      startingValues <- NULL
    } else {
      stringInitFun <- paste0(".init", gsub(" ", "", matched_model))
      initFunction <- match.fun(stringInitFun)
      startingValues <- initFunction(df, x, y, int)
    }
    if ((!matched_model %in% c("double logistic", "double gompertz")) && USEGROUP) {
      nms <- names(startingValues)
      startingValuesList <- lapply(names(startingValues), function(nm) {
        val <- startingValues[nm]
        if (nm %in% pars) {
          rep(val, length(unique(df[[group]])))
          # if this is one of pars then make starting value per group
        } else {
          val
        } # else return one starting value
      })
      names(startingValuesList) <- nms
    } else { # non-grouped, just make it into a list
      startingValuesList <- as.list(startingValues)
    }
  } else {
    startingValuesList <- start
  }
  out[["formula"]] <- growthForm
  if (type == "nlrq") {
    out[["taus"]] <- tau
  }
  out[["start"]] <- startingValuesList
  out[["df"]] <- df
  out[["pcvrForm"]] <- form
  return(out)
}

#' example of using selfStart
#' `logistic self starter`
#' @examples
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' .initlogistic(simdf, "time", "y")
#'
#' @keywords internal
#' @noRd

.initlogistic <- function(df, x, y, int = FALSE) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  if (nrow(xy) < 4) {
    stop("too few distinct input values to fit a logistic model")
  }
  z <- abs(xy[["y"]])
  ## transform to proportion, i.e. in (0,1) :
  rng <- range(z)
  dz <- diff(rng)
  z <- (z - rng[1L] + 0.05 * dz) / (1.1 * dz)
  xy[["z"]] <- log(z / (1 - z)) # logit transformation
  aux <- stats::coef(stats::lm(x ~ z, xy))
  pars <- stats::coef(stats::nls(y ~ 1 / (1 + exp((B - x) / C)),
    data = xy,
    start = list(B = aux[[1L]], C = aux[[2L]]),
    algorithm = "plinear", control = stats::nls.control(warnOnly = TRUE)
  ))
  start <- stats::setNames(pars[c(".lin", "B", "C")], c("A", "B", "C"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "A", "B", "C"))
  }
  return(start)
}


#' `Goempertz self starter`
#'
#' .initgompertz(simdf, "time", "y")
#' @keywords internal
#' @noRd

.initgompertz <- function(df, x, y, int) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  if (nrow(xy) < 4) {
    stop("too few distinct input values to fit the Gompertz model")
  }
  xyL <- xy
  xyL$y <- log(abs(xyL$y))
  pars <- stats::NLSstAsymptotic(xyL)
  pars <- stats::coef(stats::nls(y ~ exp(-B * C^x),
    data = xy, start = c(
      B = pars[["b1"]],
      C = exp(-exp(pars[["lrc"]]))
    ),
    algorithm = "plinear", control = stats::nls.control(warnOnly = TRUE)
  ))
  start <- stats::setNames(pars[c(".lin", "B", "C")], c("A", "B", "C"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "A", "B", "C"))
  }
  return(start)
}


#' `Monomolecular self starter`
#' ex<-growthSim("monomolecular", n=20, t=25,
#'                  params = list("A"=c(200,160), "B"=c(0.08, 0.1)))
#' .initmonomolecular(ex, "time", "y")
#' @keywords internal
#' @noRd

.initmonomolecular <- function(df, x, y, int) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  if (nrow(xy) < 4) {
    stop("too few distinct input values to fit a monomolecular model")
  }
  z <- abs(xy[["y"]])
  ## transform to proportion, i.e. in (0,1) :
  rng <- range(z)
  dz <- diff(rng)
  z <- (z - rng[1L] + 0.05 * dz) / (1.1 * dz)
  xy[["z"]] <- z
  aux <- stats::coef(stats::lm(z ~ x, xy))
  pars <- stats::coef(stats::nls(y ~ 1 * exp(B * x),
    data = xy, start = list(B = aux[2L]),
    algorithm = "plinear", control = stats::nls.control(warnOnly = TRUE)
  ))
  start <- stats::setNames(pars[c(".lin", "B")], c("A", "B"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "A", "B"))
  }
  return(start)
}

#' `Linear self starter`
#' @examples
#' ex <- growthSim("linear",
#'   n = 20, t = 25,
#'   params = list("A" = c(1.1, 0.95))
#' )
#' .initlinear(ex, "time", "y")
#' @keywords internal
#' @noRd

.initlinear <- function(df, x, y, int) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  if (nrow(xy) < 2) {
    stop("too few distinct input values to fit a linear model")
  }
  pars <- stats::coef(stats::lm(y ~ x, xy))
  start <- stats::setNames(pars[c("x")], c("A"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "A"))
  }
  return(start)
}

#' `Logarithmic self starter`
#' @examples
#' ex <- growthSim("logarithmic",
#'   n = 20, t = 25,
#'   params = list("A" = c(1.1, 0.95))
#' )
#' .initlinear(ex, "time", "y")
#' @keywords internal
#' @noRd

.initlogarithmic <- function(df, x, y, int) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  if (nrow(xy) < 2) {
    stop("too few distinct input values to fit a logarithmic model")
  }
  pars <- stats::coef(stats::lm(y ~ log(x), xy))
  start <- stats::setNames(pars[c("log(x)")], c("A"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "A"))
  }
  return(start)
}


#' `power law self starter`
#' @examples
#' ex <- growthSim("power law",
#'   n = 20, t = 25,
#'   params = list("A" = c(16, 11), "B" = c(0.75, 0.7))
#' )
#' .initPowerLaw(df, "time", "y")
#' @keywords internal
#' @noRd

.initpowerlaw <- function(df, x, y, int) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  if (nrow(xy) < 3) {
    stop("too few distinct input values to fit a power law model")
  }
  aux <- stats::coef(stats::lm(y ~ x, xy))

  pars <- stats::coef(stats::nls(y ~ 1 * x^B,
    data = xy, start = list(B = aux[2L]),
    algorithm = "plinear", control = stats::nls.control(warnOnly = TRUE)
  ))
  start <- stats::setNames(pars[c(".lin", "B")], c("A", "B"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "A", "B"))
  }
  return(start)
}


#' `exponential self starter`
#' @examples
#' ex <- growthSim("exponential",
#'   n = 20, t = 25,
#'   params = list("A" = c(15, 20), "B" = c(0.095, 0.095))
#' )
#' .initexponential(ex, "time", "y")
#' @keywords internal
#' @noRd

.initexponential <- function(df, x, y, int) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  if (nrow(xy) < 3) {
    stop("too few distinct input values to fit a exponential model")
  }
  aux <- stats::coef(stats::lm(y ~ x, xy))

  pars <- stats::coef(stats::nls(y ~ 1 * exp(B * x),
    data = xy, start = list(B = aux[2L]),
    algorithm = "plinear", control = stats::nls.control(warnOnly = TRUE)
  ))
  start <- stats::setNames(pars[c(".lin", "B")], c("A", "B"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "A", "B"))
  }
  return(start)
}

#' `Extreme Value Distribution Self Starter (weibull, frechet, gumbel)`
#' @keywords internal
#' @noRd

.initweibull <- function(df, x, y, int) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  if (nrow(xy) < 5) {
    stop("too few distinct input values to fit the EVD growth model")
  }
  rAsym <- stats::NLSstRtAsymptote(xy)
  pars <- stats::coef(stats::lm(
    log(-log((rAsym - y) / (rAsym - stats::NLSstLfAsymptote(xy)))) ~ log(x),
    data = xy, subset = x > 0
  ))
  start <- stats::setNames(c(rAsym, exp(pars) + c(1, 0)), c("A", "B", "C"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "A", "B", "C"))
  }
  return(start)
}
.initfrechet <- .initweibull
.initgumbel <- .initweibull

#' `bragg DRC self starter`
#' @examples
#' ex <- growthSim("bragg",
#'   n = 20, t = 25,
#'   params = list("A" = c(10, 15), "B" = c(0.01, 0.02), "C" = c(50, 60))
#' )
#' .initbragg(ex, "time", "y")
#' @keywords internal
#' @noRd

.initbragg <- function(df, x, y, int) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  x <- xy[, "x"]
  y <- xy[, "y"]
  A <- max(y) # amplitude, conventionally d
  C <- x[which.max(y)] # position of midpoint, conventionally e
  pseudoY <- log((y + 1e-04) / A)
  pseudoX <- (x - C)^2
  dat <- data.frame(pseudoY = pseudoY, pseudoX = pseudoX)
  coefs <- coef(lm(pseudoY ~ pseudoX - 1, data = dat))
  B <- -coefs[1] # pseudo precision/slope at inflection, conventionally b
  start <- stats::setNames(c(B, A, C), c("B", "A", "C"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "B", "A", "C"))
  }
  return(start)
}

#' `lorentz DRC self starter`
#' @examples
#' ex <- growthSim("lorentz",
#'   n = 20, t = 25,
#'   params = list("A" = c(10, 15), "B" = c(0.01, 0.02), "C" = c(50, 60))
#' )
#' .initlorentz(ex, "time", "y")
#' @keywords internal
#' @noRd

.initlorentz <- function(df, x, y, int) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  x <- xy[, "x"]
  y <- xy[, "y"]
  A <- max(y) # amplitude, conventionally d
  C <- x[which.max(y)] # position of midpoint, conventionally e
  pseudoY <- (A - y) / y
  pseudoX <- (x - C)^2
  dat <- data.frame(pseudoY = pseudoY, pseudoX = pseudoX)
  coefs <- coef(lm(pseudoY ~ pseudoX - 1, data = dat))
  B <- coefs[1] # pseudo precision/slope at inflection, conventionally b
  start <- stats::setNames(c(B, A, C), c("B", "A", "C"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "B", "A", "C"))
  }
  return(start)
}

#' `beta DRC self starter`
#' @examples
#' ex <- growthSim("beta",
#'   n = 20, t = 25,
#'   params = list("A" = 10, "B" = 1.2, "C" = 15, "D" = 8, "E" = 19)
#' )
#' .initbeta(ex, "time", "y")
#' @keywords internal
#' @noRd

.initbeta <- function(df, x, y, int) {
  if (int) {
    obs_min <- min(df[[y]], na.rm = TRUE)
    df[[y]] <- df[[y]] - obs_min
  }
  xy <- stats::sortedXyData(df[[x]], df[[y]])
  x <- xy[, "x"]
  y <- xy[, "y"]
  A <- max(y)
  C <- x[which.max(y)]
  firstidx <- min(which(y != 0))
  D <- ifelse(firstidx == 1,
    x[1],
    (x[firstidx] + x[(firstidx - 1)]) / 2
  )
  secidx <- max(which(y != 0))
  E <- ifelse(secidx == length(y),
    x[length(x)],
    (x[secidx] + x[(secidx + 1)]) / 2
  )
  start <- stats::setNames(c(A, 1, C, D, E), c("A", "B", "C", "D", "E"))
  if (int) {
    start <- stats::setNames(append(obs_min, start), c("I", "A", "B", "C", "D", "E"))
  }
  return(start)
}


#' `Define growth formulas`
#' @keywords internal
#' @noRd

.nlrq_form_logistic <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B", "C")
  } else {
    total_pars <- c("A", "B", "C")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~I[] + (A[]/(1+exp((B[]-", x, ")/C[])))")
  } else {
    str_nf <- paste0(y, " ~ A[]/(1+exp((B[]-", x, ")/C[]))")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_gompertz <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B", "C")
  } else {
    total_pars <- c("A", "B", "C")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~ I[] + (A[]*exp(-B[]*exp(-C[]*", x, ")))")
  } else {
    str_nf <- paste0(y, " ~ A[]*exp(-B[]*exp(-C[]*", x, "))")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_doublelogistic <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B", "C", "A2", "B2", "C2")
  } else {
    total_pars <- c("A", "B", "C", "A2", "B2", "C2")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(
      y, " ~ I[] + (A[]/(1+exp((B[]-", x, ")/C[]))",
      " + ((A2[]-A[]) /(1+exp((B2[]-", x, ")/C2[]))))"
    )
  } else {
    str_nf <- paste0(
      y, " ~ A[]/(1+exp((B[]-", x, ")/C[]))",
      " + ((A2[]-A[]) /(1+exp((B2[]-", x, ")/C2[])))"
    )
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_doublegompertz <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B", "C", "A2", "B2", "C2")
  } else {
    total_pars <- c("A", "B", "C", "A2", "B2", "C2")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(
      y, " ~ I[] + (A[] * exp(-B[] * exp(-C[]*", x, "))",
      " + (A2[]-A[]) * exp(-B2[] * exp(-C2[]*(", x, "-B[]))))"
    )
  } else {
    str_nf <- paste0(
      y, " ~ A[] * exp(-B[] * exp(-C[]*", x, "))",
      " + (A2[]-A[]) * exp(-B2[] * exp(-C2[]*(", x, "-B[])))"
    )
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_monomolecular <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B")
  } else {
    total_pars <- c("A", "B")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, "~I[] + (A[]-A[]*exp(-B[]*", x, "))")
  } else {
    str_nf <- paste0(y, "~A[]-A[]*exp(-B[]*", x, ")")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_exponential <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B")
  } else {
    total_pars <- c("A", "B")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~ I[] + (A[]*exp(B[]*", x, "))")
  } else {
    str_nf <- paste0(y, " ~ A[]*exp(B[]*", x, ")")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_linear <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A")
  } else {
    total_pars <- c("A")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~ I[] + A[]*", x)
  } else {
    str_nf <- paste0(y, " ~ A[]*", x)
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_powerlaw <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B")
  } else {
    total_pars <- c("A", "B")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~ I[] + (A[]*", x, "^B[])")
  } else {
    str_nf <- paste0(y, " ~ A[]*", x, "^B[]")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_gam <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (USEGROUP) {
    nf <- as.formula(paste0(y, " ~ bs(", x, ")*", group))
  } else {
    nf <- as.formula(paste0(y, " ~ bs(", x, ")"))
  }
  return(list("formula" = nf, "pars" = NULL))
}

.nlrqDecay <- function(form) {
  chars <- as.character(form)
  as.formula(paste0(chars[2], chars[1], "-(", chars[3], ")"))
}

.nlrq_form_frechet <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B", "C")
  } else {
    total_pars <- c("A", "B", "C")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~ I[] + (A[] * exp(-((", x, "-0)/C[])^(-B[])))")
  } else {
    str_nf <- paste0(y, " ~ A[] * exp(-((", x, "-0)/C[])^(-B[]))")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}


.nlrq_form_weibull <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B", "C")
  } else {
    total_pars <- c("A", "B", "C")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~ I[] + (A[] * (1-exp(-(", x, "/C[])^B[])))")
  } else {
    str_nf <- paste0(y, " ~ A[] * (1-exp(-(", x, "/C[])^B[]))")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_gumbel <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B", "C")
  } else {
    total_pars <- c("A", "B", "C")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~ I[] + (A[] * exp(-exp(-(", x, "-B[])/C[])))")
  } else {
    str_nf <- paste0(y, " ~ A[] * exp(-exp(-(", x, "-B[])/C[]))")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_logarithmic <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A")
  } else {
    total_pars <- c("A")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~ I[] + A[] * log(", x, ")")
  } else {
    str_nf <- paste0(y, " ~ A[] * log(", x, ")")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_bragg <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B", "C")
  } else {
    total_pars <- c("A", "B", "C")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~ I[] + A[] * exp(-B[] * (", x, " - C[])^2)")
  } else {
    str_nf <- paste0(y, " ~ A[] * exp(-B[] * (", x, " - C[])^2)")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_lorentz <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B", "C")
  } else {
    total_pars <- c("A", "B", "C")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(y, " ~ I[] + A[] / (1 + B[] * (", x, " - C[]) ^ 2)")
  } else {
    str_nf <- paste0(y, " ~ A[] / (1 + B[] * (", x, " - C[]) ^ 2)")
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

.nlrq_form_beta <- function(x, y, USEGROUP, group, pars, int = FALSE) {
  if (int) {
    total_pars <- c("I", "A", "B", "C", "D", "E")
  } else {
    total_pars <- c("A", "B", "C", "D", "E")
  }
  if (is.null(pars)) {
    pars <- total_pars
  }
  if (int) {
    str_nf <- paste0(
      y, " ~ I[] + A[] * (((", x, " - D[]) / (C[] - D[])) * ((E[] - ", x,
      ") / (E[] - C[])) ^ ((E[] - C[]) / (C[] - D[]))) ^ B[]"
    )
  } else {
    str_nf <- paste0(
      y, " ~ A[] * (((", x, " - D[]) / (C[] - D[])) * ((E[] - ", x,
      ") / (E[] - C[])) ^ ((E[] - C[]) / (C[] - D[]))) ^ B[]"
    )
  }
  if (USEGROUP) {
    for (par in total_pars) {
      if (par %in% pars) {
        str_nf <- gsub(paste0(par, "\\[\\]"), paste0(par, "[", group, "]"), str_nf)
      } else {
        str_nf <- gsub(paste0(par, "\\[\\]"), par, str_nf)
      }
    }
    nf <- as.formula(str_nf)
  } else {
    nf <- as.formula(gsub("\\[|\\]", "", str_nf))
  }
  return(list("formula" = nf, "pars" = pars))
}

#' Function to visualize common \code{stats::nls} growth models.
#'
#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
#' (and similar models made through other means) can be visualized easily using this function.
#' This will generally be called by \code{growthPlot}.
#'
#' @param fit A model fit returned by \code{fitGrowth} with type="nls".
#' @param form A formula similar to that in \code{growthSS} inputs (or the \code{pcvrForm}
#' part of the output) specifying the outcome, predictor, and grouping structure of the data as
#' \code{outcome ~ predictor|individual/group}.
#' If the individual and group are specified then the observed growth lines are plotted.
#' @param groups An optional set of groups to keep in the plot.
#' Defaults to NULL in which case all groups in the model are plotted.
#' @param df A dataframe to use in plotting observed growth curves on top of the model.
#' This must be supplied for nls models.
#' @param timeRange An optional range of times to use. This can be used to view predictions for
#' future data if the avaiable data has not reached some point (such as asymptotic size).
#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
#' @param groupFill logical, should groups have different colors? Defaults to FALSE.
#' If TRUE then viridis colormaps are used in the order of virMaps
#' @param virMaps order of viridis maps to use. Will be recycled to necessary length.
#' Defaults to "plasma", but will generally be informed by growthPlot's default.
#' @keywords growth-curve
#' @importFrom methods is
#' @import ggplot2
#' @importFrom stats predict
#' @examples
#'
#'
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   df = simdf, start = NULL, type = "nls"
#' )
#' fit <- fitGrowth(ss)
#' nlsPlot(fit, form = ss$pcvrForm, df = ss$df, groupFill = TRUE)
#' nlsPlot(fit, form = ss$pcvrForm, df = ss$df, groups = "a", timeRange = 1:10)
#'
#' @return Returns a ggplot showing an nls model's predictions.
#'
#' @export

nlsPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL,
                    facetGroups = TRUE, groupFill = FALSE, virMaps = c("plasma")) {
  #* `get needed information from formula`
  parsed_form <- .parsePcvrForm(form, df)
  #* `pick longitudinal or non-longitudinal helper`
  if (!is.numeric(df[, parsed_form$x]) && !parsed_form$USEG && !parsed_form$USEID) {
    p <- .nlsStaticPlot(
      fit, form, df, groups, timeRange,
      facetGroups, groupFill, virMaps, parsed_form
    )
    return(p)
  }
  p <- .nlsLongitudinalPlot(
    fit, form, df, groups, timeRange,
    facetGroups, groupFill, virMaps, parsed_form
  )
  return(p)
}

#' @keywords internal
#' @noRd

.nlsStaticPlot <- function(fit, form, df, groups, timeRange,
                           facetGroups, groupFill, virMaps, parsed_form) {
  x <- parsed_form$x
  df <- parsed_form$data
  #* `when implemented SE can be added here, see ?predict.nls`
  summary_df <- as.data.frame(coef(summary(mod1)))
  colnames(summary_df) <- c("est", "err", "t", "p")
  summary_df[[x]] <- rownames(summary_df)
  summary_df[1, x] <- paste0(x, unique(df[[x]])[1])
  summary_df[["est"]] <- cumsum(summary_df[["est"]])
  #* `filter by groups if groups != NULL`
  if (!is.null(groups)) {
    summary_df <- summary_df[summary_df[[x]] %in% groups, ]
  }
  #* `facetGroups`
  facet_layer <- NULL
  if (facetGroups) {
    facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", x)))
  }
  #* `groupFill`
  if (groupFill) {
    virVals <- unlist(lapply(
      rep(virMaps, length.out = length(unique(summary_df[[x]]))),
      function(pal) {
        viridis::viridis(1, begin = 0.5, option = pal)
      }
    ))
    color_scale <- ggplot2::scale_color_manual(values = virVals)
  } else {
    color_scale <- ggplot2::scale_color_manual(values = rep("#CC4678FF", length(unique(df[[x]]))))
  }
  #* `plot`
  plot <- ggplot(summary_df, ggplot2::aes(group = interaction(.data[[x]]))) +
    facet_layer +
    ggplot2::geom_errorbar(ggplot2::aes(
      x = .data[[x]],
      ymin = .data[["est"]] - 2 * .data[["err"]],
      ymax = .data[["est"]] + 2 * .data[["err"]]
    ), width = 0.25) +
    ggplot2::geom_point(ggplot2::aes(x = .data[[x]], y = .data[["est"]], color = .data[[x]]),
      size = 4
    ) +
    color_scale +
    labs(x = x, y = as.character(form)[2]) +
    pcv_theme()
  return(plot)
}

#' @keywords internal
#' @noRd

.nlsLongitudinalPlot <- function(fit, form, df, groups, timeRange,
                                 facetGroups, groupFill, virMaps, parsed_form) {
  y <- parsed_form$y
  x <- parsed_form$x
  individual <- parsed_form$individual
  if (individual == "dummyIndividual") {
    individual <- NULL
  }
  group <- parsed_form$group
  df <- parsed_form$data
  #* `filter by groups if groups != NULL`
  if (!is.null(groups)) {
    df <- df[df[[group]] %in% groups, ]
  }
  #* `make new data if timerange is not NULL`
  if (!is.null(timeRange)) {
    new_data <- do.call(rbind, lapply(unique(df[[group]]), function(g) {
      stats::setNames(data.frame(g, timeRange), c(group, x))
    }))
    df <- df[df[[x]] >= min(timeRange) & df[[x]] <= max(timeRange), ]
  } else {
    new_data <- NULL
  }
  #* `add predictions`

  preds <- data.frame(pred = stats::predict(fit, newdata = new_data))
  keep <- which(!duplicated(preds$pred))
  plotdf <- df[keep, ]
  plotdf$pred <- preds[keep, "pred"]

  #* `when implemented SE can be added here, see ?predict.nls`
  #*
  #* `layer for individual lines if formula was complete`
  individual_lines <- list()
  if (!is.null(individual)) {
    individual_lines <- ggplot2::geom_line(
      data = df, ggplot2::aes(
        x = .data[[x]], y = .data[[y]],
        group = interaction(
          .data[[individual]],
          .data[[group]]
        )
      ),
      linewidth = 0.25, color = "gray40"
    )
  }
  #* `facetGroups`
  facet_layer <- NULL
  if (facetGroups) {
    facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
  }
  #* `groupFill`
  if (groupFill) {
    virVals <- unlist(lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
      viridis::viridis(1, begin = 0.5, option = pal)
    }))
    color_scale <- ggplot2::scale_color_manual(values = virVals)
  } else {
    color_scale <- ggplot2::scale_color_manual(values = rep("#CC4678FF", length(unique(df[[group]]))))
  }

  #* `plot`
  plot <- ggplot(plotdf, ggplot2::aes(group = interaction(.data[[group]]))) +
    facet_layer +
    individual_lines +
    ggplot2::geom_line(ggplot2::aes(x = .data[[x]], y = .data[["pred"]], color = .data[[group]]),
      linewidth = 0.7
    ) + # using middle of plasma pal
    color_scale +
    labs(x = x, y = as.character(form)[2]) +
    pcv_theme()

  return(plot)
}

#' @rdname nlsPlot
#' @examples
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "gam", form = y ~ time | id / group,
#'   df = simdf, start = NULL, type = "nls"
#' )
#' fit <- fitGrowth(ss)
#' gamPlot(fit, form = ss$pcvrForm, df = ss$df, groupFill = TRUE)
#' gamPlot(fit, form = ss$pcvrForm, df = ss$df, groups = "a", timeRange = 1:10)
#' ss <- growthSS(
#'   model = "gam", form = y ~ time | group,
#'   df = simdf, start = NULL, type = "nls"
#' )
#' fit <- fitGrowth(ss)
#' gamPlot(fit, form = ss$pcvrForm, df = ss$df, groupFill = TRUE)
#'
#' @export

gamPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE,
                    groupFill = FALSE, virMaps = c("plasma")) {
  #* `get needed information from formula`
  parsed_form <- .parsePcvrForm(form, df)
  y <- parsed_form$y
  x <- parsed_form$x
  individual <- parsed_form$individual
  if (individual == "dummyIndividual") {
    individual <- NULL
  }
  group <- parsed_form$group
  df <- parsed_form$data
  #* `filter by groups if groups != NULL`
  if (!is.null(groups)) {
    df <- df[df[[group]] %in% groups, ]
  }
  #* `make new data if timerange is not NULL`
  if (!is.null(timeRange)) {
    new_data <- do.call(rbind, lapply(unique(df[[group]]), function(g) {
      stats::setNames(data.frame(g, timeRange), c(group, x))
    }))
  } else {
    # note this is the only change between this and nlsPlot
    # this change is here because predict.nls sometimes acts strangely with the given data
    # but predict.gam does not accept a NULL input for the newdata argument.
    new_data <- df
  }
  #* `add predictions`

  preds <- data.frame(pred = stats::predict(fit, newdata = new_data))
  keep <- which(!duplicated(preds$pred))
  plotdf <- df[keep, ]
  plotdf$pred <- preds[keep, "pred"]

  #* `when implemented SE can be added here, see ?predict.nls`
  #*
  #* `layer for individual lines if formula was complete`
  individual_lines <- list()
  if (!is.null(individual)) {
    individual_lines <- ggplot2::geom_line(
      data = df, ggplot2::aes(
        x = .data[[x]], y = .data[[y]],
        group = interaction(
          .data[[individual]],
          .data[[group]]
        )
      ),
      linewidth = 0.25, color = "gray40"
    )
  }
  #* `facetGroups`
  facet_layer <- NULL
  if (facetGroups) {
    facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
  }
  #* `groupFill`
  if (groupFill) {
    virVals <- unlist(lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
      viridis::viridis(1, begin = 0.5, option = pal)
    }))
    color_scale <- ggplot2::scale_color_manual(values = virVals)
  } else {
    color_scale <- ggplot2::scale_color_manual(values = rep("#CC4678FF", length(unique(df[[group]]))))
  }

  #* `plot`
  plot <- ggplot(plotdf, ggplot2::aes(group = interaction(.data[[group]]))) +
    facet_layer +
    individual_lines +
    ggplot2::geom_line(ggplot2::aes(x = .data[[x]], y = .data[["pred"]], color = .data[[group]]),
      linewidth = 0.7
    ) + # using middle of plasma pal
    color_scale +
    labs(x = x, y = as.character(form)[2]) +
    pcv_theme()

  return(plot)
}

#' @rdname nlsPlot
#' @examples
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "gam", form = y ~ time | id / group,
#'   df = simdf, start = NULL, type = "nls"
#' )
#' fit <- fitGrowth(ss)
#' lmPlot(fit, form = ss$pcvrForm, df = ss$df)
#' @export

lmPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE,
                   groupFill = FALSE, virMaps = c("plasma")) {
  nlsPlot(fit, form, df, groups, timeRange, facetGroups, groupFill, virMaps)
}

#' @description
#' Internal function for calculating \mu and \kappa of a distribution represented by single value
#' traits.
#' @param s1 A vector of numerics generated from a circular process
#' @examples
#' .conj_vonmises2_sv(
#'   s1 = brms::rvon_mises(100, 2, 2), priors = list(mu = 0.5, kappa = 0.5),
#'   cred.int.level = 0.95,
#'   plot = FALSE
#' )
#' .conj_vonmises2_sv(
#'   s1 = rnorm(20, 90, 20),
#'   priors = list(mu = 75, kappa = 0.5, boundary = c(0, 180)),
#'   cred.int.level = 0.95,
#'   plot = TRUE
#' )
#' @keywords internal
#' @noRd

.conj_vonmises2_sv <- function(s1 = NULL, priors = NULL,
                               plot = FALSE, support = NULL, cred.int.level = NULL,
                               calculatingSupport = FALSE) {
  #* `set support to NULL to avoid default length of 10000`
  support <- NULL
  #* `make default prior if none provided`
  default_prior <- list(
    mu = 0, kappa = 0.5,
    boundary = c(-pi, pi),
    n = 1
  )
  if (is.null(priors)) {
    priors <- default_prior
  }
  #* `if any elements are missing from prior then use defaults`
  priors <- stats::setNames(lapply(names(default_prior), function(nm) {
    if (nm %in% names(priors)) {
      return(priors[[nm]])
    } else {
      return(default_prior[[nm]])
    }
  }), names(default_prior))
  #* `rescale data to [-pi, pi] according to boundary`
  s1 <- .boundary.to.radians(x = s1, boundary = priors$boundary)
  #* `rescale prior on mu to [-pi, pi] according to boundary`
  mu_radians <- .boundary.to.radians(x = priors$mu, boundary = priors$boundary)
  #* `Raise error if the boundary is wrong and data is not on [-pi, pi]`
  if (any(abs(s1) > pi)) {
    stop(paste0(
      "Values must be on [-pi, pi] after rescaling. ",
      "Does the boundary element in your prior include all your data?"
    ))
  }
  #* `Define dense Support`
  if (is.null(support)) {
    if (calculatingSupport) {
      return(priors$boundary) #* this would be [-pi, pi] if using radians, but plotting will be on
      #* the original scale so we can just return the boundary and use [-pi, pi] as support here
    }
    support_boundary <- seq(min(priors$boundary), max(priors$boundary), by = 0.0005)
    support <- seq(-pi, pi, length.out = length(support_boundary))
  }
  out <- list()
  #* ***** `Updating Kappa`
  n1 <- length(s1)
  obs_kappa <- .unbiased.kappa(s1, n1)
  kappa_prime <- ((obs_kappa * n1) + (priors$kappa * priors$n)) / (n1 + priors$n)
  #* ***** `Updating vMF for mu using kappa prime`
  #* `Get weighted mean of data and prior for half tangent adjustment`
  cm <- .circular.mean(c(s1, mu_radians), w = c(rep(1, length(s1)), priors$n))
  unitCircleAdj <- ifelse(abs(cm) <= pi / 2, 0, pi)
  unitCircleAdj <- ifelse(cm > 0, 1, -1) * unitCircleAdj
  #* `Update prior parameters`
  a <- priors$kappa # kappa parameter can easily overwhelm mean in updating with low sample size
  # I do not love this currently. It seems like a should be kappa prime, but that very easily
  # overwhelms small samples in the follow formula to update mu, so instead of the sequential
  # updating I am using separate updating.
  # the formula below basically weighs the prior by kappa, so if I update kappa then weigh the prior
  # by that then it is much more biased towards the prior, I think that is worth avoiding with this
  # workaround
  b <- mu_radians
  mu_prime_atan_scale <- atan(((a * sin(b)) + sum(sin(s1))) / ((a * cos(b)) + sum(cos(s1))))
  mu_prime <- unitCircleAdj + mu_prime_atan_scale
  #* `calculate density over support`
  dens1 <- brms::dvon_mises(support, mu_prime, kappa_prime)
  pdf1 <- dens1 / sum(dens1)
  #* `calculate highest density interval`
  #* note there is no qvon_mises function, so I am using bayestestR::hdi on
  #* posterior draws and rescaled posterior draws
  draws <- brms::rvon_mises(10000, mu_prime, kappa_prime)
  hdi_v1 <- as.numeric(bayestestR::hdi(draws, ci = cred.int.level))[2:3]
  draws2 <- draws
  draws2[draws2 < 0] <- draws2[draws2 < 0] + 2 * pi
  hdi_v2 <- as.numeric(bayestestR::hdi(draws2, ci = cred.int.level))[2:3]
  hdis <- list(hdi_v1, hdi_v2)
  hdi <- hdis[[which.min(c(diff(hdi_v1), diff(hdi_v2)))]]
  hdi[hdi > pi] <- hdi[hdi > pi] - (2 * pi) # if the second hdi was narrower then fix the part beyond pi
  #* `store highest density estimate`
  hde <- mu_prime
  #* `Rescale HDI, HDE, and draws, from radians to boundary units`
  hdi_boundary <- .radians.to.boundary(hdi, target = priors$boundary)
  hde_boundary <- .radians.to.boundary(hde, target = priors$boundary)
  draws_boundary <- .radians.to.boundary(draws, target = priors$boundary)
  #* `save summary and parameters`
  out$summary <- data.frame(
    HDE_1 = hde_boundary,
    HDI_1_low = hdi_boundary[1],
    HDI_1_high = hdi_boundary[2]
  )
  out$posterior$mu <- hde_boundary # rescaled mu_prime
  out$posterior$kappa <- kappa_prime
  out$posterior$n <- priors$n + length(s1)
  out$posterior$boundary <- priors$boundary
  #* `Store Posterior Draws`
  out$posteriorDraws <- draws_boundary
  out$pdf <- pdf1
  #* `keep data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support_boundary, "prob" = pdf1,
      "sample" = rep("Sample 1", length(support_boundary))
    )
  } # tests on this seem to work fine
  return(out)
}

#' @description
#' Internal function for calculating \mu and \kappa of a distribution represented by multi value
#' traits.
#' @param s1 A vector of numerics generated from a circular process
#' @examples
#' mv_gauss <- mvSim(
#'   dists = list(
#'     rnorm = list(mean = 50, sd = 10)
#'   ),
#'   n_samples = 30
#' )
#' .conj_vonmises2_mv(
#'   s1 = mv_gauss[, -1], priors = list(mu = 30, kappa = 1, boundary = c(0, 180)),
#'   cred.int.level = 0.95,
#'   plot = TRUE
#' )
#' @keywords internal
#' @noRd

.conj_vonmises2_mv <- function(s1 = NULL, priors = NULL,
                               plot = FALSE, support = NULL, cred.int.level = NULL,
                               calculatingSupport = FALSE) {
  #* `set support to NULL to avoid default length of 10000`
  support <- NULL
  #* `Reorder columns if they are not in the numeric order`
  histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
  bins_order <- sort(histColsBin, index.return = TRUE)$ix
  s1 <- s1[, bins_order]
  #* `Turn s1 matrix into a vector`
  X1 <- rep(histColsBin[bins_order], as.numeric(round(colSums(s1))))
  #* `make default prior if none provided`
  default_prior <- list(
    mu = 0, kappa = 0.5,
    boundary = c(-pi, pi),
    n = 1
  )
  if (is.null(priors)) {
    priors <- default_prior
  }
  #* `if any elements are missing from prior then use defaults`
  priors <- stats::setNames(lapply(names(default_prior), function(nm) {
    if (nm %in% names(priors)) {
      return(priors[[nm]])
    } else {
      return(default_prior[[nm]])
    }
  }), names(default_prior))
  #* `rescale data to [-pi, pi] according to boundary`
  X1 <- .boundary.to.radians(x = X1, boundary = priors$boundary)
  #* `rescale prior on mu to [-pi, pi] according to boundary`
  mu_radians <- .boundary.to.radians(x = priors$mu, boundary = priors$boundary)
  #* `Raise error if the boundary is wrong and data is not on [-pi, pi]`
  if (any(abs(X1) > pi)) {
    stop(paste0(
      "Values must be on [-pi, pi] after rescaling. ",
      "Does the boundary element in your prior include all your data?"
    ))
  }
  #* `Define dense Support`
  if (is.null(support)) {
    if (calculatingSupport) {
      return(priors$boundary) #* this would be [-pi, pi] if using radians, but plotting will be on
      #* the original scale so we can just return the boundary and use [-pi, pi] as support here
    }
    support_boundary <- seq(min(priors$boundary), max(priors$boundary), by = 0.0005)
    support <- seq(-pi, pi, length.out = length(support_boundary))
  }
  out <- list()
  #* ***** `Updating Kappa`
  n1 <- nrow(s1)
  obs_kappa <- .unbiased.kappa(X1, length(X1))
  kappa_prime <- ((obs_kappa * n1) + (priors$kappa * priors$n)) / (n1 + priors$n)
  #* ***** `Updating vMF for mu using kappa prime`
  #* `Get weighted mean of data and prior for half tangent adjustment`
  cm <- .circular.mean(c(X1, mu_radians), w = c(rep(nrow(s1) / length(X1), length(X1)), priors$n))
  unitCircleAdj <- ifelse(abs(cm) <= pi / 2, 0, pi)
  unitCircleAdj <- ifelse(cm > 0, 1, -1) * unitCircleAdj
  #* `Update prior parameters`
  a <- priors$kappa
  b <- mu_radians
  mu_prime_atan_scale <- atan(((a * sin(b)) + sum(sin(X1))) / ((a * cos(b)) + sum(cos(X1))))
  mu_prime <- unitCircleAdj + mu_prime_atan_scale
  #* `calculate density over support`
  dens1 <- brms::dvon_mises(support, mu_prime, kappa_prime)
  pdf1 <- dens1 / sum(dens1)
  #* `calculate highest density interval`
  #* note there is no qvon_mises function, so I am using bayestestR::hdi on
  #* posterior draws and rescaled posterior draws
  draws <- brms::rvon_mises(10000, mu_prime, kappa_prime)
  hdi_v1 <- as.numeric(bayestestR::hdi(draws, ci = cred.int.level))[2:3]
  draws2 <- draws
  draws2[draws2 < 0] <- draws2[draws2 < 0] + 2 * pi
  hdi_v2 <- as.numeric(bayestestR::hdi(draws2, ci = cred.int.level))[2:3]
  hdis <- list(hdi_v1, hdi_v2)
  hdi <- hdis[[which.min(c(diff(hdi_v1), diff(hdi_v2)))]]
  hdi[hdi > pi] <- hdi[hdi > pi] - (2 * pi) # if the second hdi was narrower then fix the part beyond pi
  #* `store highest density estimate`
  hde <- mu_prime
  #* `Rescale HDI, HDE, draws, and support from radians to boundary units`
  hdi_boundary <- .radians.to.boundary(hdi, target = priors$boundary)
  hde_boundary <- .radians.to.boundary(hde, target = priors$boundary)
  draws_boundary <- .radians.to.boundary(draws, target = priors$boundary)
  #* `save summary and parameters`
  out$summary <- data.frame(
    HDE_1 = hde_boundary,
    HDI_1_low = hdi_boundary[1],
    HDI_1_high = hdi_boundary[2]
  )
  out$posterior$mu <- hde_boundary # rescaled mu_prime
  out$posterior$kappa <- kappa_prime
  out$posterior$n <- priors$n + nrow(s1)
  out$posterior$boundary <- priors$boundary
  #* `Store Posterior Draws`
  out$posteriorDraws <- draws_boundary
  out$pdf <- pdf1
  #* `keep data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support_boundary, "prob" = pdf1,
      "sample" = rep("Sample 1", length(support_boundary))
    )
  }
  return(out)
}




#' @description
#' Function calculating inverse of the ratio of first and zeroth order bessel functions.
#' This is a biased estimate of kappa, with small samples sizes the bias is strong.
#' @param x A vector of numerics from a von mises distribution
#' @examples
#' x <- brms::rvon_mises(100, 3, 2)
#' .bessel.inv(mean(cos(x - .circular.mean(x))))
#' @keywords internal
#' @noRd

.bessel.inv <- function(x) {
  ifelse(0 <= x & x < 0.53,
    2 * x + x^3 + (5 * x^5) / 6,
    ifelse(x < 0.85,
      -0.4 + 1.39 * x + 0.43 / (1 - x),
      1 / (x^3 - 4 * x^2 + 3 * x)
    )
  )
}

#' @description
#' helper function to estimate kappa based on data generated from a von mises distribution.
#' This is used from the CircStats package.
#' @param x sample of numeric draws from a von-mises distribution
#' @param n the number of samples used. If NULL, the default, then length(x) is used. If this is <16
#' then the bias adjustment from Best, D. and Fisher N. (1981) is used.
#' @examples
#' .unbiased.kappa(brms::rvon_mises(15, 3, 2))
#' @keywords internal
#' @noRd

.unbiased.kappa <- function(x, n = NULL) {
  if (is.null(n)) {
    n <- length(x)
  }
  mean.dir <- .circular.mean(x)
  kappa <- .bessel.inv(mean(cos(x - mean.dir)))
  if (n < 16) {
    kappa.biased <- kappa
    if (kappa.biased < 2) {
      kappa <- max(kappa.biased - 2 * (n * kappa.biased)^-1, 0)
    } else {
      kappa <- ((n - 1)^3 * kappa.biased) / (n^3 + n)
    }
  }
  kappa
}

#' Helper function for parsing pcvr formulas used in growthSS and downstream functions
#'
#' @param form The pcvr style formula specifying outcome, predictor, individuals, and groups.
#' @param df The data that will be used to fit the model
#'
#' @keywords internal
#' @noRd

.parsePcvrForm <- function(form, df = NULL) {
  #* `parse form argument`
  y <- as.character(form)[2]
  x <- as.character(form)[3]
  USEGROUP <- FALSE
  if (grepl("\\|", x) && grepl("\\/", x)) { # Y ~ X per id within group
    x3 <- trimws(strsplit(x, "[|]|[/]")[[1]])
    x <- x3[1]
    individual <- x3[2]
    group <- x3[length(x3)]
    USEINDIVIDUAL <- TRUE
    if (!is.null(df)) {
      if (length(unique(df[[group]])) == 1) {
        USEGROUP <- FALSE
      } else {
        USEGROUP <- TRUE
      } # if there is only one group then ignore grouping
    }
  } else if (grepl("\\|", x)) { # Y ~ X by group
    x2 <- trimws(strsplit(x, "[|]")[[1]])
    x <- x2[1]
    individual <- "dummyIndividual"
    df[[individual]] <- "dummyIndividual"
    group <- x2[length(x2)]
    USEGROUP <- TRUE
    USEINDIVIDUAL <- FALSE
  } else { # Y ~ X
    x2 <- trimws(strsplit(x, "[|]")[[1]])
    x <- x2[1]
    individual <- "dummyIndividual"
    group <- "dummyGroup"
    if (!is.null(df)) {
      df[[individual]] <- "dummyIndividual"
      df[[group]] <- "dummyGroup"
    }
    USEGROUP <- FALSE
    USEINDIVIDUAL <- FALSE
  }
  if (grepl("\\+", x)) {
    x_components <- lapply(strsplit(x, "\\+"), trimws)
    x <- x_components[[1]][1]
    hierarchical_predictor <- x_components[[1]][2]
  } else {
    hierarchical_predictor <- NULL
  }
  if (!is.null(df)) {
    tryCatch(
      {
        df <- df[complete.cases(df[, c(x, y, individual, group)]), ]
      },
      error = function(err) {}
    )
  }
  return(list(
    "y" = y, "x" = x, "individual" = individual, "group" = group,
    "USEG" = USEGROUP, "USEID" = USEINDIVIDUAL, "data" = df,
    "hierarchical_predictor" = hierarchical_predictor
  ))
}

#' Earth Mover's Distance between spectral histograms
#'
#' @description pcv.emd can be used to calculate Earth Mover's Distance between pairwise histograms
#' in a wide dataframe of multi value traits. The is expected to be used with output from \code{mv_ag}.
#' See also \link{pcv.euc} for euclidean distance between histograms.
#'
#' @param df Data frame to use with multi value traits in wide format or long format
#' @param cols Columns to use. Defaults to NULL in which case all columns are used.
#' Single strings will be used to regex a pattern in column names (see examples).
#'  A vector of names, positions, or booleans will also work.
#'  For long data this is taken as a regex pattern (or full name)
#'  to use in filtering the trait column.
#' @param reorder Should data be reordered to put similar rows together in the resulting plot?
#'  This takes a vector of column names of length 1 or more (see examples).
#' @param include if a long dataframe is returned then these columns will be added to the dataframe,
#'  labelled for i and j (the row positions for compared histograms).
#'  If a matrix is returned then this information is stored in the row names.
#'  This defaults to reorder.
#' @param mat Logical, should data be returned as an nrow x nrow matrix or as a long dataframe?
#'  By Default this is FALSE and a long dataframe is returned.
#'  Both options are comparable in terms of speed,
#'  although for large datasets the matrix version may be slightly faster.
#' @param plot Logical, should a plot be returned? For a matrix this is made with heatmap(),
#'  for a dataframe this uses ggplot.
#' @param parallel Number of cores to use. Defaults to 1 unless the "mc.cores" option is set.
#' @param trait Column name for long data to identify traits. This defaults to "trait". If this and
#' value are in the column names of the data then it is assumed to be in long format,
#' otherwise it is assumed to be in wide format.
#' @param id A vector of column names that uniquely identifies observations if the
#' data is in long format. Defaults to "image".
#' @param value A column name for the values to be drawn from in long data.
#' Defaults to "value".
#' @param raiseError Logical, should warnings/errors be raised for potentially large output?
#'  It is easy to ask for very many comparisons with this function so the goal of this argument
#'  is to catch a few of those and give estimates of how much time something may take.
#'   If the function is expected to take very long then a warning or an error is raised.
#'    If this is set to FALSE then no time estimates are made.
#' @param method Which method to use (one of "emd" or "euc"). Defaults to "emd".
#' @import ggplot2
#' @import parallel
#' @return A dataframe/matrix (if plot=FALSE) or a list with a dataframe/matrix and\
#' a ggplot (if plot=TRUE). The returned data contains pairwise EMD values.
#'
#' @keywords emd earth-mover's-distance multi-value histogram
#' @examples
#'
#'
#' set.seed(123)
#' test <- mvSim(
#'   dists = list(
#'     runif = list(min = 0, max = 100),
#'     rnorm = list(mean = 90, sd = 20)
#'   ),
#'   n_samples = 10
#' )
#' test$meta1 <- rep(LETTERS[1:3], length.out = nrow(test))
#' test$meta2 <- rep(LETTERS[4:5], length.out = nrow(test))
#'
#' x <- pcv.emd(
#'   df = test, cols = "sim", reorder = "group",
#'   include = c("meta1", "meta2"), mat = FALSE,
#'   plot = FALSE, parallel = 1
#' )
#' head(x)
#' x2 <- pcv.emd(
#'   df = test, cols = "sim", reorder = "group",
#'   include = c("meta1", "meta2"), mat = FALSE,
#'   plot = FALSE, parallel = 1, method = "euc"
#' )
#' head(x2)
#'
#' \donttest{
#' library(data.table)
#' file <- paste0(
#'   "https://media.githubusercontent.com/media/joshqsumner/",
#'   "pcvrTestData/main/pcv4-multi-value-traits.csv"
#' )
#' df1 <- read.pcv(file, "wide", reader = "fread")
#'
#' df1$genotype <- substr(df1$barcode, 3, 5)
#' df1$genotype <- ifelse(df1$genotype == "002", "B73",
#'   ifelse(df1$genotype == "003", "W605S",
#'     ifelse(df1$genotype == "004", "MM", "Mo17")
#'   )
#' )
#' df1$fertilizer <- substr(df1$barcode, 8, 8)
#' df1$fertilizer <- ifelse(df1$fertilizer == "A", "100",
#'   ifelse(df1$fertilizer == "B", "50", "0")
#' )
#'
#' tryCatch(
#'   {
#'     w <- pcv.emd(df1,
#'       cols = "hue_frequencies", reorder = c("fertilizer", "genotype"),
#'       mat = FALSE, plot = TRUE, parallel = 1
#'     )
#'   },
#'   error = function(err) {
#'     message(err)
#'   }
#' )
#'
#' # Note on computational complexity
#' # This scales as O^2, see the plot below for some idea
#' # of the time for different input data sizes.
#' emdTime <- function(x, n = 1) {
#'   x^2 / n * 0.0023
#' }
#' plot(
#'   x = c(18, 36, 54, 72, 108, 135), y = c(0.74, 2.89, 6.86, 10.99, 26.25, 42.44),
#'   xlab = "N Input Images", ylab = "time (seconds)"
#' ) # benchmarked test data
#' lines(x = 1:150, y = emdTime(1:150)) # exponential function
#'
#' plot(
#'   x = 1:1000, y = emdTime(1:1000), type = "l",
#'   xlab = "N Input Images", ylab = "time (seconds)"
#' )
#' }
#'
#' @export
#'
pcv.emd <- function(df, cols = NULL, reorder = NULL, include = reorder, mat = FALSE, plot = TRUE,
                    parallel = getOption("mc.cores", 1), trait = "trait", id = "image",
                    value = "value", raiseError = TRUE, method = "emd") {
  if (all(c(trait, value) %in% colnames(df))) {
    long <- TRUE
    traitCol <- trait
  } else {
    long <- FALSE
  }
  if (!is.null(reorder)) {
    df <- df[order(interaction(df[, reorder])), ]
  }
  if (long) {
    out_data <- .longEmdCalculation(
      df, cols, traitCol, raiseError,
      parallel, id, value, include, mat, method
    )
  } else { # wide input

    out_data <- .wideEmdCalculation(df, cols, raiseError, parallel, id, include, mat, method)
  }
  if (plot) {
    if (mat) {
      p <- stats::heatmap(out_data)
    } else {
      p <- ggplot2::ggplot(out_data, ggplot2::aes(x = .data$i, y = .data$j, fill = .data[[method]])) +
        ggplot2::geom_tile(color = NA) +
        ggplot2::labs(fill = method) +
        ggplot2::theme_minimal() +
        ggplot2::theme(
          axis.line.x.bottom = ggplot2::element_line(), axis.line.y.left = ggplot2::element_line(),
          legend.position = "bottom"
        )
    }
    outList <- list("data" = out_data, "plot" = p)
  } else {
    outList <- out_data
  }
  return(outList)
}


#' Error Raising function for very long EMD calculation times
#' @keywords internal
#' @noRd

.emdRaiseError <- function(raiseError, df, parallel, trait = NULL) {
  n <- ifelse(is.null(trait), nrow(df), nrow(df) / length(unique(df[[trait]])))
  if (raiseError) {
    et_sec <- 0.00125 * ((n / parallel)^2)
    et_min <- et_sec / 60
    et_hour <- et_min / 60
    if (et_sec <= 300) {
      message(paste0(
        "Estimated time of calculation is roughly ", round(et_sec, 1),
        " seconds using ", parallel, " cores in parallel."
      ))
    } else if (et_min < 60) {
      warning(paste0(
        "Estimated time of calculation is roughly ", round(et_min, 2),
        " minutes using ", parallel, " cores in parallel."
      ))
    } else if (et_min > 60) {
      stop(paste0(
        "Stopping, estimated time of calculation is roughly ", round(et_hour, 2),
        " hours using ", parallel, " cores in parallel.",
        "\nIf you wish to proceed then rerun this command with raiseError=FALSE"
      ))
    }
  }
}

#' Long EMD calculation
#' @keywords internal
#' @noRd

.longEmdCalculation <- function(df, cols, traitCol, raiseError, parallel, id,
                                value, include, mat, method) {
  dist_1d <- match.fun(paste0(method, "1d"))
  df <- df[grepl(cols, df[[traitCol]]), ]
  #* `raise error`
  .emdRaiseError(raiseError, df, parallel, trait = traitCol)
  #* `calculate emd`
  df$INNER_ID_EMD <- interaction(df[, id], drop = TRUE)
  if (mat) { # make dist matrix
    mat_obj <- matrix(0,
      nrow = length(unique(df$INNER_ID_EMD)),
      ncol = length(unique(df$INNER_ID_EMD))
    )
    values <- unlist(lapply(seq_along(unique(df$INNER_ID_EMD)), function(i_n) {
      parallel::mclapply(seq_along(unique(df$INNER_ID_EMD)), function(j_n) {
        i <- unique(df$INNER_ID_EMD)[i_n]
        j <- unique(df$INNER_ID_EMD)[j_n]
        if (i_n < j_n) {
          dist_1d(
            as.numeric(df[df$INNER_ID_EMD == as.character(i), value]),
            as.numeric(df[df$INNER_ID_EMD == as.character(j), value])
          )
        }
      }, mc.cores = parallel)
    }))
    mat_obj[lower.tri(mat_obj)] <- values
    tmat_obj <- t(mat_obj)
    mat_obj[upper.tri(mat_obj)] <- tmat_obj[upper.tri(tmat_obj)]
    rownames(mat_obj) <- colnames(mat_obj) <- unique(df$INNER_ID_EMD)
    out_data <- mat_obj
  } else { # make long data
    out_data <- do.call(rbind, lapply(seq_along(unique(df$INNER_ID_EMD)), function(i_n) {
      do.call(rbind, parallel::mclapply(seq_along(unique(df$INNER_ID_EMD)), function(j_n) {
        i <- unique(df$INNER_ID_EMD)[i_n]
        j <- unique(df$INNER_ID_EMD)[j_n]
        emdOut <- NULL
        if (i_n == j_n) {
          emdOut <- 0
        } else if (i_n < j_n) {
          emdOut <- dist_1d(
            as.numeric(df[df$INNER_ID_EMD == as.character(i), value]),
            as.numeric(df[df$INNER_ID_EMD == as.character(j), value])
          )
        }
        if (!is.null(emdOut)) {
          if (!is.null(include)) {
            x <- rbind(
              data.frame(
                i = i, j = j, emd = emdOut,
                df[df$INNER_ID_EMD == as.character(i), include][1, ],
                df[df$INNER_ID_EMD == as.character(j), include][1, ]
              ),
              data.frame(
                i = j, j = i, emd = emdOut,
                df[df$INNER_ID_EMD == as.character(j), include][1, ],
                df[df$INNER_ID_EMD == as.character(i), include][1, ]
              )
            )
            colnames(x) <- c("i", "j", method, paste0(include, "_i"), paste0(include, "_j"))
          } else {
            x <- data.frame(i = c(i, j), j = c(j, i), emd = emdOut)
          }
          x
        }
      }, mc.cores = parallel))
    }))
  }
  return(out_data)
}

#* wide EMD calculation
#' @keywords internal
#' @noRd

.wideEmdCalculation <- function(df, cols, raiseError, parallel, id, include, mat, method) {
  dist_1d <- match.fun(paste0(method, "1d"))
  if (is.null(cols)) {
    cols <- colnames(df)
  } else if (is.character(cols) && length(cols) == 1) {
    cols <- grepl(cols, colnames(df))
  }
  #* `raise error`
  .emdRaiseError(raiseError, df, parallel, trait = NULL)
  #* `calculate emd`
  if (mat) { # make dist matrix
    mat_obj <- matrix(0, nrow = nrow(df), ncol = nrow(df))
    values <- unlist(lapply(seq_len(nrow(df)), function(i) {
      parallel::mclapply(seq_len(nrow(df)), function(j) {
        if (i < j) {
          dist_1d(as.numeric(df[i, cols]), as.numeric(df[j, cols]))
        }
      }, mc.cores = parallel)
    }))
    mat_obj[lower.tri(mat_obj)] <- values
    tmat_obj <- t(mat_obj)
    mat_obj[upper.tri(mat_obj)] <- tmat_obj[upper.tri(tmat_obj)]
    rownames(mat_obj) <- colnames(mat_obj) <- seq_len(nrow(df))
    out_data <- mat_obj
    if (!is.null(include)) {
      rownames(out_data) <- interaction(df[, include])
    }
  } else { # make long dataframe
    out_data <- do.call(rbind, lapply(seq_len(nrow(df)), function(i) {
      do.call(rbind, parallel::mclapply(seq_len(nrow(df)), function(j) {
        emdOut <- NULL
        if (i == j) {
          emdOut <- 0
        } else if (i < j) {
          emdOut <- dist_1d(as.numeric(df[i, cols]), as.numeric(df[j, cols]))
        }
        if (!is.null(emdOut)) {
          if (!is.null(include)) {
            x <- rbind(
              data.frame(i = i, j = j, emd = emdOut, df[i, include], df[j, include]),
              data.frame(i = j, j = i, emd = emdOut, df[j, include], df[i, include])
            )
            colnames(x) <- c("i", "j", method, paste0(include, "_i"), paste0(include, "_j"))
          } else {
            x <- data.frame(i = c(i, j), j = c(j, i), emd = emdOut)
          }
          x
        }
      }, mc.cores = parallel))
    }))
  }
  return(out_data)
}

#' Earth Mover's Distance between spectral histograms
#'
#' @description emd1d computes 1 dimension EMD for two samples.
#'
#' @param s1 Histogram as a numeric vector of counts per position.
#' @param s2 Histogram as a numeric vector of counts per position. Must be the same length as s1.
#'
#' @keywords internal
#' @return Returns EMD between two samples as a numeric.
#' @examples
#'
#' set.seed(123)
#' s1 <- hist(rnorm(10000, 50, 10), breaks = seq(1, 100, 1))$counts
#' s2 <- hist(rlnorm(9000, log(30), 0.25), breaks = seq(1, 100, 1))$counts
#' plot(s2, type = "l"); lines(s1)
#' emd1d(s1, s2)
#'
#' @noRd
#'
emd1d <- function(s1, s2) {
  if (length(s1) != length(s2)) {
    stop("Samples must be from the same histogram and be of the same length")
  }
  s1 <- s1 / sum(s1)
  s2 <- s2 / sum(s2)
  emd_iter <- numeric(length(s1) + 1)
  for (i in seq_along(s1)) {
    emd_iter[i + 1] <- s1[i] - s2[i] + emd_iter[i]
  }
  return(sum(abs(emd_iter)))
}

#' Euclidean Distance between spectral histograms
#'
#' @description euc1d computes euclidean distance between two samples.
#'
#' @param s1 Histogram as a numeric vector of counts per position.
#' @param s2 Histogram as a numeric vector of counts per position. Must be the same length as s1.
#'
#' @importFrom stats dist
#' @keywords internal
#' @return Returns euclidean distance as a numeric
#'
#' @noRd

euc1d <- function(s1, s2) {
  if (length(s1) != length(s2)) {
    stop("Samples must be from the same histogram and be of the same length")
  }
  s1 <- s1 / sum(s1)
  s2 <- s2 / sum(s2)
  mat <- matrix(c(s1, s2), nrow = 2, byrow = TRUE)
  euc <- as.numeric(stats::dist(mat, method = "euclidean"))
  return(euc)
}

#' @rdname pcv.emd
#' @export
#'
pcv.euc <- function(df, cols = NULL, reorder = NULL, include = reorder, mat = FALSE, plot = TRUE,
                    parallel = getOption("mc.cores", 1), trait = "trait", id = "image",
                    value = "value", raiseError = TRUE, method = "euc") {
  pcv.emd(df, cols, reorder, include, mat, plot, parallel, trait, id, value, raiseError, method)
}

#' Helper function to put together formulae for brms changepoint growth models
#'
#' @param model A multi-part model passed from brmSS passed from \code{\link{growthSS}}
#' @param x The x variable from the pcvrForm argument in \code{\link{growthSS}}
#' @param y The y variable from the pcvrForm argument in \code{\link{growthSS}}
#' @param group The grouping variable from the pcvrForm argument in \code{\link{growthSS}}
#' @param dpar Logical, is this a distributional parameter formula (TRUE) or part of the main growth
#' formula (FALSE)?
#' @param nTimes a Number of times that are present in the data, only used for making splines have a
#' workable number of knots.
#' @param useGroup logical, should groups be used?
#' @param priors A list describing priors in the style of \code{\link{brmSS}}, \code{\link{growthSS}},
#' and \code{\link{growthSim}}. This is only used currently to identify fixed and estimated
#' changepoints. If a changepoint is called "changePointX" with X being its position in the formula
#' then it will be estimated as a parameter in the model, but if the changepoint is called
#' "fixedChangePointX" then it will be passed as a numeric in the growth model.
#' @param int logical, should an intercept be modeled?
#'
#' @examples
#' df1 <- do.call(rbind, lapply(1:30, function(i) {
#'   chngpt <- rnorm(2, 10, 1.5)
#'   A <- growthSim("linear", n = 1, t = chngpt[1], params = list("A" = c(1)))
#'   B <- growthSim("linear", n = 1, t = chngpt[2], params = list("A" = c(0.9)))
#'   B$group <- "b"
#'   x <- rbind(A, B)
#'   x$id <- paste0("id_", i)
#'   x
#' }))
#' df2 <- growthSim("linear", n = 30, t = 20, params = list("A" = c(4.1, 5)))
#' df2 <- do.call(rbind, lapply(unique(paste0(df2$id, df2$group)), function(int) {
#'   df1sub <- df1[paste0(df1$id, df1$group) == int, ]
#'   df2sub <- df2[paste0(df2$id, df2$group) == int, ]
#'   y_end <- df1sub[df1sub$time == max(df1sub$time), "y"]
#'   df2sub$time <- df2sub$time + max(df1sub$time)
#'   df2sub$y <- y_end + df2sub$y
#'   df2sub
#' }))
#' df <- rbind(df1, df2)
#' ggplot(df, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   theme_minimal()
#'
#' .brmsChangePointHelper(model = "linear + linear", x = "time", y = "y", group = "group")
#'
#' @keywords internal
#' @noRd

.brmsChangePointHelper <- function(model, x, y, group, dpar = FALSE,
                                   nTimes = 25, useGroup, priors, int = FALSE) {
  component_models <- trimws(strsplit(model, "\\+")[[1]])
  models <- c(
    "logistic", "gompertz", "monomolecular", "exponential", "linear", "power law", "gam",
    "spline", "int", "homo", "weibull", "frechet", "gumbel", "logarithmic"
  )

  if (dpar) {
    prefix <- y
  } else {
    prefix <- NULL
  }

  mainGrowthModelPriorStrings <- paste(
    paste0("^", gsub(
      " ", "",
      c(models, "changePoint", "fixedChangePoint")
    )),
    collapse = "|"
  )
  if (dpar) {
    priors <- priors[grepl(prefix, names(priors))]
  } else {
    priors <- priors[grepl(mainGrowthModelPriorStrings, names(priors))]
  }
  # else should be any prior whose name starts with a model name,
  # with changePoint or with fixedChangePoint.

  formulae <- lapply(seq_along(component_models), function(i) {
    iter_model <- component_models[i]

    if (grepl("decay", iter_model)) {
      decay <- TRUE
      iter_model <- trimws(gsub("decay", "", iter_model))
    } else {
      decay <- FALSE
    }

    matched_iter_model <- match.arg(iter_model, models)
    matched_iter_model <- gsub("homo", "int", matched_iter_model) # recoding
    matched_iter_model <- gsub("spline", "gam", matched_iter_model) # recoding

    chngptFormFun <- get(paste0(".", gsub(" ", "", matched_iter_model), "ChngptForm"))
    iter <- chngptFormFun(x, i, dpar = prefix, priors)
    if (decay) {
      iter <- .decayChngptForm(iter)
    }
    return(iter)
  })

  params <- unique(unlist(lapply(formulae, function(f) {
    f$params
  })))
  params <- params[-length(params)]

  if (int) { # for changepoint models with an intercept add I term to formula and params
    formula_starter_string <- paste0(y, " ~ ", prefix, "I + ")
    params <- append(params, paste0(prefix, "I"))
  } else {
    formula_starter_string <- paste0(y, " ~ ")
  }

  growthForm <- paste0(formula_starter_string, formulae[[1]]$form, " * ", formulae[[1]]$cp)
  #* Make cpInt cumulative
  for (i in 2:length(formulae)) {
    cumulativeCpInt <- do.call(paste, list(lapply(1:i, function(o) {
      formulae[[o]]$cpInt
    }), collapse = " + "))
    formulae[[i]]$cpInt <- cumulativeCpInt
  }
  # assemble segments into complete formula
  for (i in 2:length(formulae)) {
    nextPhase <- paste0(
      "+ (", formulae[[(i - 1)]]$cpInt, " + ", formulae[[i]]$form, ") * ",
      formulae[[i]]$cp
    )
    growthForm <- paste0(growthForm, nextPhase)
  }
  tryCatch(
    expr = {
      growthForm <- stats::as.formula(growthForm)
    },
    error = function(err) {
      message(paste0(
        "Error while assembling changepoint formula, did you specify priors for ",
        paste(params, collapse = ", "), "? Changepoint priors must be named."
      ))
      message("The original Error message is:")
      stop(conditionMessage(err))
    }
  )
  growthForm <- stats::as.formula(growthForm)

  if (dpar) {
    growthForm <- brms::nlf(growthForm)
  }

  splineSegments <- which(unlist(lapply(formulae, function(fml) {
    "splineVar" %in% names(fml)
  })))

  splineForm <- .handleSplineSegments(splineSegments, useGroup, group, nTimes, formulae, x)

  return(list("growthForm" = growthForm, "pars" = params, "splineHelperForm" = splineForm))
}

#* ****************************************
#* ***** `Handle Spline Segments` *****
#* ****************************************

#' spline formula helper function
#' @keywords internal
#' @noRd

.handleSplineSegments <- function(splineSegments, useGroup, group, nTimes, formulae, x) {
  if (length(splineSegments) > 0) {
    if (useGroup) {
      by <- paste0(", by = ", group)
    } else {
      by <- ","
    }
    if (nTimes < 11) {
      k <- paste0(", k = ", nTimes)
    } else {
      k <- NULL
    }
    splineVars <- c()
    for (seg in splineSegments) {
      splineVars <- c(splineVars, formulae[[seg]]$splineVar)
    }
    lhs <- paste0(splineVars, collapse = "+")
    rhs <- paste0("s(", x, by, k, ")")
    splineForm <- paste0(lhs, "~", rhs)
  } else {
    splineForm <- NULL
  }
  return(splineForm)
}


#* ****************************************
#* ***** `Linear Changepoint Phase` *****
#* ****************************************

#' Linear changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .linearChngptForm(x = "time", 1)
#' .linearChngptForm(x = "time", 2)
#' .linearChngptForm(x = "time", 3)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value.
#' @noRd

.linearChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value, even in sub model
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }

    form <- paste0(prefix, "linear", position, "A * ", x)
    cp <- paste0("inv_logit((", chngptPrefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0("(", prefix, "linear", position, "A * ", chngptPrefix, changePointObj, ")")
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prevAndCurrentChangePoints <- all_chngpts[which(
      as.numeric(sub(".*hangePoint", "", all_chngpts)) %in% c(position, position - 1)
    )]
    #* per location where "fixed" is in the prior name, replace the name with that number.
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }
    pac_fixed_index <- which(grepl("fixed", prevAndCurrentChangePoints))
    if (length(pac_fixed_index) > 0) {
      prevAndCurrentChangePoints[pac_fixed_index] <- as.numeric(
        priors[prevAndCurrentChangePoints[pac_fixed_index]]
      )
    }

    form <- paste0(
      prefix, "linear", position, "A * (", x, "-",
      paste0(prevChangePoints, collapse = "-"), ")"
    )
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(
      prefix, "linear", position, "A * (", paste0(rev(prevAndCurrentChangePoints),
        collapse = "-"
      ),
      ")"
    )
    #* cpInt would be wrong for the last position but it isn't used.
  }

  pars <- paste0(prefix, "linear", position, "A")
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }

  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}


#* ****************************************
#* ***** `Logistic Changepoint Phase` *****
#* ****************************************

#' Logistic changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .logisticChngptForm(x = "time", 1)
#' .logisticChngptForm(x = "time", 2)
#' .logisticChngptForm(x = "time", 3)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value.
#'
#' @noRd

.logisticChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }

    form <- paste0(
      prefix, "logistic", position, "A / (1 + exp( (", prefix, "logistic", position,
      "B-(", x, "))/", prefix, "logistic", position, "C) )"
    )
    cp <- paste0("inv_logit((", chngptPrefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0(
      prefix, "logistic", position, "A / (1 + exp( (", prefix, "logistic", position,
      "B-(", chngptPrefix, changePointObj, "))/", prefix, "logistic", position, "C) )"
    )
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prevAndCurrentChangePoints <- all_chngpts[which(
      as.numeric(sub(".*hangePoint", "", all_chngpts)) %in% c(position, position - 1)
    )]
    #* per location where "fixed" is in the prior name, replace the name with that number.
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }
    pac_fixed_index <- which(grepl("fixed", prevAndCurrentChangePoints))
    if (length(pac_fixed_index) > 0) {
      prevAndCurrentChangePoints[pac_fixed_index] <- as.numeric(
        priors[prevAndCurrentChangePoints[pac_fixed_index]]
      )
    }

    form <- paste0(
      prefix, "logistic", position, "A / (1 + exp( (", prefix, "logistic", position,
      "B-(", x, "-", paste0(prevChangePoints, collapse = "-"),
      "))/", prefix, "logistic", position, "C) )"
    )
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(
      prefix, "logistic", position, "A / (1 + exp( (", prefix, "logistic", position,
      "B-(", paste0(rev(prevAndCurrentChangePoints), collapse = "-"), "))/", prefix, "logistic",
      position, "C) )"
    )
  }
  pars <- paste0(prefix, "logistic", position, c("A", "B", "C"))
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }
  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}


#* ****************************************
#* ***** `Gompertz Changepoint Phase` *****
#* ****************************************

#' Gompertz changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .gompertzChngptForm(x = "time", 1)
#' .gompertzChngptForm(x = "time", 2)
#' .gompertzChngptForm(x = "time", 3)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value.
#' @noRd

.gompertzChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }
    form <- paste0(
      prefix, "gompertz", position, "A * exp(-", prefix, "gompertz", position,
      "B * exp(-", prefix, "gompertz", position, "C * ", x, "))"
    )
    cp <- paste0("inv_logit((", prefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0(
      prefix, "gompertz", position, "A * exp(-", prefix, "gompertz", position,
      "B * exp(-", prefix, "gompertz", position, "C * ", chngptPrefix, changePointObj,
      "))"
    )
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prevAndCurrentChangePoints <- all_chngpts[which(
      as.numeric(sub(".*hangePoint", "", all_chngpts)) %in% c(position, position - 1)
    )]
    #* per location where "fixed" is in the prior name, replace the name with that number.
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }
    pac_fixed_index <- which(grepl("fixed", prevAndCurrentChangePoints))
    if (length(pac_fixed_index) > 0) {
      prevAndCurrentChangePoints[pac_fixed_index] <- as.numeric(
        priors[prevAndCurrentChangePoints[pac_fixed_index]]
      )
    }

    form <- paste0(
      prefix, "gompertz", position, "A * exp(-", prefix, "gompertz", position,
      "B * exp(-", prefix, "gompertz", position, "C * (", x, " - ",
      paste0(prevChangePoints, collapse = "-"), ")))"
    )

    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(
      prefix, "gompertz", position, "A * exp(-", prefix, "gompertz", position, "B * exp(-", prefix,
      "gompertz", position,
      "C * (", paste0(rev(prevAndCurrentChangePoints), collapse = "-"), "))"
    )
  }
  pars <- paste0(prefix, "gompertz", position, c("A", "B", "C"))
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }
  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}

#* ****************************************
#* ***** `monomolecular Changepoint Phase` *****
#* ****************************************

#' Monomolecular changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .monomolecularChngptForm(x = "time", 1)
#' .monomolecularChngptForm(x = "time", 2)
#' .monomolecularChngptForm(x = "time", 3)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value.
#'
#' @noRd

.monomolecularChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }
    form <- paste0(
      prefix, "monomolecular", position, "A-", prefix, "monomolecular", position,
      "A * exp(-", prefix, "monomolecular", position, "B * ", x, ")"
    )
    cp <- paste0("inv_logit((", chngptPrefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0(
      prefix, "monomolecular", position, "A-", prefix, "monomolecular", position,
      "A * exp(-", prefix, "monomolecular", position, "B * ", chngptPrefix,
      changePointObj, ")"
    )
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prevAndCurrentChangePoints <- all_chngpts[which(
      as.numeric(sub(".*hangePoint", "", all_chngpts)) %in% c(position, position - 1)
    )]
    #* per location where "fixed" is in the prior name, replace the name with that number.
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }
    pac_fixed_index <- which(grepl("fixed", prevAndCurrentChangePoints))
    if (length(pac_fixed_index) > 0) {
      prevAndCurrentChangePoints[pac_fixed_index] <- as.numeric(
        priors[prevAndCurrentChangePoints[pac_fixed_index]]
      )
    }

    form <- paste0(
      prefix, "monomolecular", position, "A-", prefix, "monomolecular", position, "A * exp(-",
      prefix, "monomolecular", position, "B * ", x, "-",
      paste0(prevChangePoints, collapse = "-"), ")"
    )
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(
      prefix, "monomolecular", position, "A-", prefix, "monomolecular", position, "A * exp(-",
      prefix, "monomolecular", position, "B * ",
      paste0(rev(prevAndCurrentChangePoints), collapse = "-"), ")"
    )
  }
  pars <- paste0(prefix, "monomolecular", position, c("A", "B"))
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }
  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}


#* ****************************************
#* ***** `Exponential Changepoint Phase` *****
#* ****************************************

#' Exponential changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .exponentialChngptForm(x = "time", 1)
#' .exponentialChngptForm(x = "time", 2)
#' .exponentialChngptForm(x = "time", 3)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value.
#' @noRd

.exponentialChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }

    form <- paste0(
      prefix, "exponential", position, "A * exp(", prefix, "exponential", position,
      "B * ", x, ")"
    )
    cp <- paste0("inv_logit((", chngptPrefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0(
      prefix, "exponential", position, "A * exp(", prefix, "exponential", position,
      "B * ", chngptPrefix, changePointObj, ")"
    )
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prevAndCurrentChangePoints <- all_chngpts[which(
      as.numeric(sub(".*hangePoint", "", all_chngpts)) %in% c(position, position - 1)
    )]
    #* per location where "fixed" is in the prior name, replace the name with that number.
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }
    pac_fixed_index <- which(grepl("fixed", prevAndCurrentChangePoints))
    if (length(pac_fixed_index) > 0) {
      prevAndCurrentChangePoints[pac_fixed_index] <- as.numeric(
        priors[prevAndCurrentChangePoints[pac_fixed_index]]
      )
    }

    form <- paste0(
      prefix, "exponential", position, "A * exp(", prefix, "exponential", position, "B * (",
      x, "-", paste0(prevChangePoints, collapse = "-"), "))"
    )
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(
      prefix, "exponential", position, "A * exp(", prefix, "exponential", position, "B * (",
      paste0(rev(prevAndCurrentChangePoints), collapse = "-"), "))"
    )
  }
  pars <- paste0(prefix, "exponential", position, c("A", "B")) # this needs to be conditional on fixed
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }
  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}

#* ****************************************
#* ***** `Power Law Changepoint Phase` *****
#* ****************************************

#' Power Law changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .powerlawChngptForm(x = "time", 1)
#' .powerlawChngptForm(x = "time", 2)
#' .powerlawChngptForm(x = "time", 3)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value.
#'
#' @noRd

.powerlawChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }
    form <- paste0(prefix, "powerLaw", position, "A * ", x, "^(", prefix, "powerLaw", position, "B)")
    cp <- paste0("inv_logit((", chngptPrefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0(
      prefix, "powerLaw", position, "A * ", chngptPrefix, changePointObj, "^(", prefix,
      "powerLaw", position, "B)"
    )
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prevAndCurrentChangePoints <- all_chngpts[which(
      as.numeric(sub(".*hangePoint", "", all_chngpts)) %in% c(position, position - 1)
    )]
    #* per location where "fixed" is in the prior name, replace the name with that number.
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }
    pac_fixed_index <- which(grepl("fixed", prevAndCurrentChangePoints))
    if (length(pac_fixed_index) > 0) {
      prevAndCurrentChangePoints[pac_fixed_index] <- as.numeric(
        priors[prevAndCurrentChangePoints[pac_fixed_index]]
      )
    }

    form <- paste0(
      prefix, "powerLaw", position, "A * ", x, "-",
      paste0(prevChangePoints, collapse = "-"), "^(", prefix, "powerLaw", position, "B)"
    )
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(
      prefix, "powerLaw", position, "A * (", paste0(rev(prevAndCurrentChangePoints), collapse = "-"),
      ")^(", prefix, "powerLaw", position, "B)"
    )
  }
  pars <- paste0(prefix, "powerLaw", position, c("A", "B"))
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }
  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}

#* ****************************************
#* ***** `Logarithmic Changepoint Phase` *****
#* ****************************************

#' Logarithmic changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .logarithmicChngptForm(x = "time", 1)
#' .logarithmicChngptForm(x = "time", 2)
#' .logarithmicChngptForm(x = "time", 3)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value.
#'
#' @noRd

.logarithmicChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }
    form <- paste0(prefix, "logarithmic", position, "A * log(", x, ")")
    cp <- paste0("inv_logit((", chngptPrefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0(
      prefix, "logarithmic", position, "A * log(", chngptPrefix, changePointObj, ")"
    )
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prevAndCurrentChangePoints <- all_chngpts[which(
      as.numeric(sub(".*hangePoint", "", all_chngpts)) %in% c(position, position - 1)
    )]
    #* per location where "fixed" is in the prior name, replace the name with that number.
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }
    pac_fixed_index <- which(grepl("fixed", prevAndCurrentChangePoints))
    if (length(pac_fixed_index) > 0) {
      prevAndCurrentChangePoints[pac_fixed_index] <- as.numeric(
        priors[prevAndCurrentChangePoints[pac_fixed_index]]
      )
    }

    form <- paste0(
      prefix, "logarithmic", position, "A * log(", x, "-",
      paste0(prevChangePoints, collapse = "-"), ")"
    )
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(
      prefix, "logarithmic", position, "A * log(",
      paste0(rev(prevAndCurrentChangePoints), collapse = "-"),
      ")"
    )
  }
  pars <- paste0(prefix, "powerLaw", position, c("A"))
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }
  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}

#* ****************************************
#* ***** `Intercept Changepoint Phase` *****
#* ****************************************

#' intercept only changepoint section function
#'
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .intChngptForm(x = "time", 1, nTimes = 20)
#' .intChngptForm(x = "time", 2, nTimes = 20)
#' .intChngptForm(x = "time", 3, nTimes = 5)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value, for GAMs this is
#' undefined and GAMs should only be used at the end of a segmented model.
#' @noRd

.intChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }
    form <- paste0(prefix, "int", position)
    cp <- paste0("inv_logit((", chngptPrefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0(prefix, "int", position)
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }

    form <- paste0(prefix, "int", position)
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(prefix, "int", position)
  }

  pars <- paste0(prefix, "int", position)
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }

  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}




#* ****************************************
#* ***** `Gam Changepoint Phase` *****
#* ****************************************

#' gam changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .gamChngptForm(x = "time", 1, nTimes = 20)
#' .gamChngptForm(x = "time", 2, nTimes = 20)
#' .gamChngptForm(x = "time", 3, nTimes = 5)
#'
#' @return a list with form, cp, cpInt, and splineForm elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value, for GAMs this is
#' undefined and GAMs should only be used at the end of a segmented model.
#' "splineForm" is to use in making a spline for a predictor.
#' @noRd

.gamChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    stop("GAMs are only supported as the last function of a multi-part formula")
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }

    form <- paste0(prefix, "spline")
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- NA
  }
  pars <- paste0(prefix, "spline")
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }
  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars,
    "splineVar" = paste0(prefix, "spline")
  ))
}

#* ****************************************
#* ***** `Gam Changepoint Phase` *****
#* ****************************************

#' flip any model to a decay model
#'
#' @param phaseList A list returned from some *ChngptForm function
#'
#' @return a list with form, cp, cpInt and params for a decay segment to a model
#' @noRd

.decayChngptForm <- function(phaseList) {
  phaseList$form <- paste0("-", phaseList$form)
  phaseList
}

#* ****************************************
#* ***** `Weibull Changepoint Phase` *****
#* ****************************************

#' Weibull changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .weibullChngptForm(x = "time", 1)
#' .weibullChngptForm(x = "time", 2)
#' .weibullChngptForm(x = "time", 3)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value.
#'
#' @noRd

.weibullChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }
    form <- paste0(
      prefix, "weibull", position, "A * (1-exp(-(", x, "/", prefix,
      "weibull", position, "C)^", prefix, "weibull", position, "B))"
    )
    cp <- paste0("inv_logit((", chngptPrefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0(
      prefix, "weibull", position, "A * (1-exp(-(", chngptPrefix, changePointObj,
      "/", prefix, "weibull", position, "C)^", prefix, "weibull", position, "B))"
    )
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prevAndCurrentChangePoints <- all_chngpts[which(
      as.numeric(sub(".*hangePoint", "", all_chngpts)) %in% c(position, position - 1)
    )]
    #* per location where "fixed" is in the prior name, replace the name with that number.
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }
    pac_fixed_index <- which(grepl("fixed", prevAndCurrentChangePoints))
    if (length(pac_fixed_index) > 0) {
      prevAndCurrentChangePoints[pac_fixed_index] <- as.numeric(
        priors[prevAndCurrentChangePoints[pac_fixed_index]]
      )
    }
    form <- paste0(
      prefix, "weibull", position, "A * (1-exp(-(", x, "-", paste0(prevChangePoints, collapse = "-"),
      "/", prefix, "weibull", position, "C)^", prefix, "weibull", position, "B))"
    )
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(
      prefix, "weibull", position, "A * (1-exp(-(", paste0(rev(prevAndCurrentChangePoints),
        collapse = "-"
      ),
      "/", prefix, "weibull", position, "C)^", prefix, "weibull", position, "B))"
    )
  }
  pars <- paste0(prefix, "weibull", position, c("A", "B", "C"))
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }
  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}


#* ****************************************
#* ***** `Frechet Changepoint Phase` *****
#* ****************************************

#' Frechet changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .frechetChngptForm(x = "time", 1)
#' .frechetChngptForm(x = "time", 2)
#' .frechetChngptForm(x = "time", 3)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value.
#'
#' @noRd

.frechetChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt

  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }
    form <- paste0(
      prefix, "frechet", position, "A * exp(-((", x, "-0)/", prefix, "frechet",
      position, "C)^(-", prefix, "frechet", position, "B))"
    )
    cp <- paste0("inv_logit((", chngptPrefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0(
      prefix, "frechet", position, "A * exp(-((", chngptPrefix, changePointObj, "-0)/",
      prefix, "frechet", position, "C)^(-", prefix, "frechet", position, "B))"
    )
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prevAndCurrentChangePoints <- all_chngpts[which(
      as.numeric(sub(".*hangePoint", "", all_chngpts)) %in% c(position, position - 1)
    )]
    #* per location where "fixed" is in the prior name, replace the name with that number.
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }
    pac_fixed_index <- which(grepl("fixed", prevAndCurrentChangePoints))
    if (length(pac_fixed_index) > 0) {
      prevAndCurrentChangePoints[pac_fixed_index] <- as.numeric(
        priors[prevAndCurrentChangePoints[pac_fixed_index]]
      )
    }

    form <- paste0(
      prefix, "frechet", position, "A * exp(-((", x, "-", paste0(prevChangePoints, collapse = "-"),
      "-0)/", prefix, "frechet", position, "C)^(-", prefix, "frechet", position, "B))"
    )
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(
      prefix, "frechet", position, "A * exp(-((", paste0(rev(prevAndCurrentChangePoints),
        collapse = "-"
      ),
      "-0)/", prefix, "frechet", position, "C)^(-", prefix, "frechet", position, "B))"
    )
  }
  pars <- paste0(prefix, "frechet", position, c("A", "B", "C"))
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }
  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}


#* ****************************************
#* ***** `Gumbel Changepoint Phase` *****
#* ****************************************

#' Gumbel changepoint section function
#'
#' @param x X variable name
#' @param position Position in growth formula ("1" + "2" + "3"... etc)
#' @param dpar string or NULL, if string should be the name of the distributional parameter
#' @param priors a list of prior distributions (used for fixed vs estimated changepoints)
#'
#' @examples
#'
#' .gumbelChngptForm(x = "time", 1)
#' .gumbelChngptForm(x = "time", 2)
#' .gumbelChngptForm(x = "time", 3)
#'
#' @return a list with form, cp, and cpInt elements. "form" is the growth formula
#' for this phase of the model. "cp" is the inv_logit function defining when this
#' phase should happen. "cpInt" is the value at the end of this growth phase and is
#' used in starting the next growth phase from the right y value.
#'
#' @noRd

.gumbelChngptForm <- function(x, position = 1, dpar = NULL, priors) { # return f, cp, and cpInt


  prefix <- chngptPrefix <- dpar

  if (any(grepl(paste0("fixedChangePoint", position), names(priors)))) {
    changePointObj <- as.numeric(priors[[paste0(prefix, "fixedChangePoint", position)]])[1]
    fixed <- TRUE
    chngptPrefix <- NULL # never a prefix if the changepoint is a fixed value
  } else {
    fixed <- FALSE
  }

  if (position == 1) {
    if (!fixed) {
      changePointObj <- "changePoint1"
    }
    form <- paste0(
      prefix, "gumbel", position, "A * exp(-exp(-(", x, "-",
      prefix, "gumbel", position, "B)/", prefix, "gumbel", position, "C))"
    )
    cp <- paste0("inv_logit((", chngptPrefix, changePointObj, " - ", x, ") * 5)")
    cpInt <- paste0(
      prefix, "gumbel", position, "A * exp(-exp(-(", chngptPrefix, changePointObj, "-",
      prefix, "gumbel", position, "B)/", prefix, "gumbel", position, "C))"
    )
  } else {
    all_chngpts <- names(priors)[grepl("fixedChangePoint*|changePoint*", names(priors))]
    prevChangePoints <- all_chngpts[which(as.numeric(sub(".*hangePoint", "", all_chngpts)) < position)]
    prevAndCurrentChangePoints <- all_chngpts[which(
      as.numeric(sub(".*hangePoint", "", all_chngpts)) %in% c(position, position - 1)
    )]
    #* per location where "fixed" is in the prior name, replace the name with that number.
    prev_fixed_index <- which(grepl("fixed", prevChangePoints))
    if (length(prev_fixed_index) > 0) {
      prevChangePoints[prev_fixed_index] <- as.numeric(priors[prevChangePoints[prev_fixed_index]])
    }
    pac_fixed_index <- which(grepl("fixed", prevAndCurrentChangePoints))
    if (length(pac_fixed_index) > 0) {
      prevAndCurrentChangePoints[pac_fixed_index] <- as.numeric(
        priors[prevAndCurrentChangePoints[pac_fixed_index]]
      )
    }

    form <- paste0(
      prefix, "gumbel", position, "A * exp(-exp(-(", x, "-", paste0(prevChangePoints, collapse = "-"),
      "-", prefix, "gumbel", position, "B)/", prefix, "gumbel", position, "C))"
    )
    cp <- paste0("inv_logit((", x, "-", paste0(prevChangePoints, collapse = "-"), ") * 5)")
    cpInt <- paste0(
      prefix, "gumbel", position, "A * exp(-exp(-(", paste0(rev(prevAndCurrentChangePoints),
        collapse = "-"
      ),
      "-", prefix, "gumbel", position, "B)/", prefix, "gumbel", position, "C))"
    )
  }
  pars <- paste0(prefix, "gumbel", position, c("A", "B", "C"))
  if (!fixed) {
    pars <- c(pars, paste0(chngptPrefix, "changePoint", position))
  }
  return(list(
    "form" = form,
    "cp" = cp,
    "cpInt" = cpInt,
    "params" = pars
  ))
}

#' @description
#' Internal function for calculating the gamma distributed scale parameter of a pareto distribution
#' represented by multi value traits.
#' @param s1 A data.frame or matrix of multi value traits.
#' @examples
#' library(extraDistr)
#' s1 <- mvSim(
#'   dists = list(rpareto = list(a = 1, b = 1)),
#'   n_samples = 10,
#'   counts = 50,
#'   min_bin = 1,
#'   max_bin = 180,
#'   wide = TRUE
#' )[, -1]
#' out <- .conj_pareto_mv(s1, cred.int.level = 0.95)
#' lapply(out, head)
#'
#' @keywords internal
#' @noRd
.conj_pareto_mv <- function(s1 = NULL, priors = NULL,
                            plot = FALSE, support = NULL, cred.int.level = NULL,
                            calculatingSupport = FALSE) {
  out <- list()
  #* `N observations`
  n_obs <- nrow(s1)
  #* `Reorder columns if they are not in the numeric order`
  histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
  bins_order <- sort(histColsBin, index.return = TRUE)$ix
  s1 <- s1[, bins_order]
  #* `Min non-zero bin`
  obs_min <- min(unlist(lapply(seq_len(n_obs), function(i) {
    col <- colnames(s1)[which(s1[i, ] > 0)][1]
    as.numeric(gsub("[a-zA-Z]_*", "", col))
  })), na.rm = TRUE)
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(a = 0.5, b = 0.5, known_location = obs_min)
  }
  #* `Note, the product of the data is not an obvious quantity with MV trait data.`
  #* I talk about this some in my notes on 5/30/2024 but I think it might be a good chance
  #* to try the alternative mv trait method that I'd been considering.
  #* `Calculate Sufficient Statistics`
  #* This is abnormal because one of the sufficient statistics is the product of the data.
  #* That quantity does not translate well to the MV trait setting.
  #* `MLE Estimates of Pareto Parameters`
  #* Note this is being done per row of the MV data
  row_scales <- unlist(lapply(seq_len(n_obs), function(i) {
    d <- s1[i, ]
    #* `Turn s1 matrix into a vector`
    X1 <- rep(histColsBin[bins_order], as.numeric(round(colSums(d))))
    #* `Estimate parameters of pareto distribution of this row`
    scale_mle <- sum(d) / sum(log(X1))
    return(scale_mle)
  }))
  scale_estimate <- mean(row_scales)
  sv_draws <- extraDistr::rpareto(n_obs, scale_estimate, priors$known_location)
  #* `Update gamma prior with sufficient statistics`
  n <- length(sv_draws)
  m <- prod(sv_draws)
  a_prime <- priors$a + n
  b_prime <- 1 / (1 / priors$b + log(m) - n * log(priors$known_location))
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qgamma(c(0.0001, 0.9999), a_prime, b_prime)
    return(quantiles)
  }
  #* `Make Posterior Draws`
  out$posteriorDraws <- rgamma(10000, a_prime, b_prime)
  #* `posterior`
  dens1 <- dgamma(support, a_prime, b_prime)
  pdf1 <- dens1 / sum(dens1)
  out$pdf <- pdf1
  hde1 <- .gammaHDE(shape = a_prime, scale = 1 / b_prime)
  hdi1 <- qgamma(
    c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    a_prime, b_prime
  )
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior <- list(
    "a" = a_prime,
    "b" = b_prime,
    "known_location" = priors$known_location
  )
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' @description
#' Internal function for calculating the gamma distributed scale parameter of a pareto distribution
#' represented by single value traits.
#' @param s1 A vector of numerics drawn from a pareto distribution.
#' @examples
#' out <- .conj_pareto_sv(
#'   s1 = runif(10, 1, 1), cred.int.level = 0.95,
#'   plot = FALSE
#' )
#' lapply(out, head)
#' @keywords internal
#' @noRd
.conj_pareto_sv <- function(s1 = NULL, priors = NULL,
                            plot = FALSE, support = NULL, cred.int.level = NULL,
                            calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(a = 0.5, b = 0.5, known_location = floor(min(s1)))
  }
  #* `Update gamma prior with sufficient statistics`
  n <- length(s1)
  m <- prod(s1)
  a_prime <- priors$a + n
  b_prime <- 1 / (1 / priors$b + log(m) - n * log(priors$known_location))
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qgamma(c(0.0001, 0.9999), a_prime, b_prime)
    return(quantiles)
  }
  #* `Make Posterior Draws`
  out$posteriorDraws <- rgamma(10000, a_prime, b_prime)
  #* `posterior`
  dens1 <- dgamma(support, a_prime, b_prime)
  pdf1 <- dens1 / sum(dens1)
  out$pdf <- pdf1
  hde1 <- .gammaHDE(shape = a_prime, scale = 1 / b_prime)
  hdi1 <- qgamma(
    c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    a_prime, b_prime
  )
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior <- list(
    "a" = a_prime,
    "b" = b_prime,
    "known_location" = priors$known_location
  )
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' Ease of use brms starter function for 6 growth model parameterizations
#'
#' @param model The name of a model as a character string.
#' Supported options are "logistic", "gompertz", "frechet", "gumbel", "weibull",
#' "monomolecular", "exponential", "linear", "logarithmic",
#' "power law", "double logistic", "double gompertz", and "gam".
#' See \code{\link{growthSim}} for examples of each type of growth curve.
#' @param form A formula describing the model. The left hand side should only be
#' the outcome variable (phenotype). The right hand side needs at least the x variable
#'  (typically time). Grouping is also described in this formula using roughly lme4
#'  style syntax,with formulas like \code{y~time|individual/group} to show that predictors
#'  should vary by \code{group} and autocorrelation between \code{individual:group}
#'  interactions should be modeled. If group has only one level or is not included then
#'  it will be ignored in formulas for growth and variance (this may be the case if
#'  you split data before fitting models to be able to run more smaller models each more quickly).
#' @param sigma A model for heteroskedasticity from the same list of options as the model argument.
#' @param df A dataframe to use. Must contain all the variables listed in the formula.
#' @param priors A named list of means for prior distributions.
#'  Currently this function makes lognormal priors for all growth model parameters
#'  and T_5(mu, 3) priors for changepoint parameters.
#'   This is done because the values are strictly positive and the lognormal distribution
#'   is easily interpreted. The changepoint priors are T distributions for symmetry, 5 DF
#'   having been chosen for heavy but not unmanageable tails.
#'   If this argument is not provided then priors are not
#'   returned and a different set of priors will need to be made for the model using
#'   \code{brms::set_prior}. This works similarly to the \code{params} argument
#'   in \code{growthSim}. Names should correspond to parameter names from the
#'   \code{model} argument. A numeric vector can also be used, but specifying
#'   names is best practice for clarity. Additionally, due to a limitation in
#'   \code{brms} currently lower bounds cannot be set for priors for specific groups.
#'   If priors include multiple groups (\code{priors = list(A = c(10,15), ...)}) then
#'   you will see warnings after the model is fit about not having specified a lower
#'   bound explicitly. Those warnings can safely be ignored and will be addressed if
#'   the necessary features are added to \code{brms}. For GAMs priors are not created by
#'   this function but can still be provided as a \code{brmsprior} object.
#'   See details for guidance.
#' @param int Logical, should an intercept term be included?
#' @keywords Bayesian, brms
#'
#' @importFrom stats as.formula rgamma
#'
#' @details
#'
#' Default informative priors are not provided,
#' but these can serve as starting points for each distribution.
#' You are encouraged to use \code{growthSim} to consider what kind
#' of trendlines result from changes to your prior and for interpretation of each parameter.
#' You should not looking back and forth at your data trying to match your
#'  observed growth exactly with a prior distribution,
#' rather this should be informed by an understanding of the plants you
#'  are using and expectations based on previous research.
#'  For the "double" models the parameter interpretation is the same
#'  as for their non-double counterparts except that there are A and A2, etc.
#'  It is strongly recommended to familiarize yourself with the double sigmoid
#'  distributions using growthSim before attempting to model one. Additionally,
#'  those distributions are intended for use with long delays in an experiment,
#'  think stress recovery experiments, not for minor hiccups in plant growth.
#'
#' \itemize{
#'    \item \bold{Logistic}: \code{list('A' = 130, 'B' = 12, 'C' = 3)}
#'     \item \bold{Gompertz}: \code{list('A' = 130, 'B' = 12, 'C' = 1.25)}
#'     \item \bold{Double Logistic}: \code{list('A' = 130, 'B' = 12, 'C' = 3,
#'     'A2' = 200, 'B2' = 25, 'C2' = 1)}
#'     \item \bold{Double Gompertz}: \code{list('A' = 130, 'B' = 12, 'C' = 0.25,
#'     'A2' = 220, 'B2' = 30, 'C2' = 0.1)}
#'     \item \bold{Monomolecular}: \code{list('A' = 130, 'B' = 2)}
#'     \item \bold{Exponential}: \code{list('A' = 15, 'B' = 0.1)}
#'     \item \bold{Linear}: \code{list('A' = 1)}
#'     \item \bold{Power Law}: \code{list('A' = 13, 'B' = 2)}
#' }
#'
#'
#'
#' The \code{sigma} argument optionally specifies a sub model to account for heteroskedasticity.
#' Currently there are four supported sub models described below.
#'
#' \itemize{
#'    \item \bold{homo}: \code{sigma ~ 1}, fitting only a global or per group intercept to sigma.
#'     \item \bold{linear}: \code{sigma ~ time}, modeling sigma with a linear relationship to time
#'      and possibly with an interaction term per groups.
#'     \item \bold{spline}: \code{sigma ~ s(time)}, modeling sigma using a smoothing function through
#'     `mgcv::s`, possibly by group.
#'     \item \bold{gompertz}: \code{sigma ~ subA * exp(-subB * exp(-subC * x))},
#'      modeling sigma as a gompertz function of time, possibly by group. Note that you
#'      should specify priors for the parameters in this sub model by adding them into the \code{priors}
#'      argument, such as \code{list(..., subA = 20, subB = 15, subC = 0.25)}. If you do not specify
#'      priors then default (flat) priors will be used, which is liable to cause fitting problems
#'      and less accurate results. Looking at your data and making a semi-informed estimate of the
#'      total variance at the end of the experiment can help set a reasonable prior for subA, while
#'      subB and subC can generally be the same as B and C in a gompertz growth model of the same data.
#'      These priors will have fat tails so they are pretty forgiving.
#' }
#'
#'
#' @return A named list of elements to make it easier to fit common brms models.
#' \code{formula}: A \code{brms::bf} formula specifying the growth model, autocorrelation, variance
#' submodel, and models for each variable in the growth model.
#' \code{prior}: A brmsprior/data.frame object.
#' \code{initfun}: A function to randomly initialize chains using a random draw from a gamma
#' distribution (confines initial values to positive and makes correct number
#' of initial values for chains and groups). For "gam" models this initializes all chains at 0.
#' \code{df} The data input, possibly with dummy variables added if needed.
#' \code{family} The model family, currently this will always be "student".
#' \code{pcvrForm} The form argument unchanged. This is returned so that
#' it can be used later on in model visualization. Often it may be a good idea
#' to save the output of this function with the fit model, so having this can
#' be useful later on.
#' @examples
#'
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- .brmSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   sigma = "spline", df = simdf, priors = list("A" = 130, "B" = 12, "C" = 3)
#' )
#' lapply(ss, class)
#' ss$initfun()
#'
#' @keywords internal
#' @noRd

.brmSS <- function(model, form, sigma = NULL, df, priors = NULL, int = FALSE, hierarchy = NULL) {
  out <- list()
  models <- c(
    "int", "logistic", "gompertz", "monomolecular", "exponential", "linear", "power law", "logarithmic",
    "double logistic", "double gompertz", "gam", "spline", "homo", "frechet", "gumbel", "weibull",
    "not_estimated", "bragg", "lorentz", "beta"
  )
  #* ***** `Make bayesian formula` *****
  #* `parse form argument`
  parsed_form <- .parsePcvrForm(form, df)
  y <- parsed_form$y
  if (grepl("\\[", y)) {
    lims <- gsub(".*\\[|\\]", "", y)
    lims <- as.numeric(strsplit(lims, ",")[[1]])
    lower <- lims[1]
    upper <- lims[2]
    y <- trimws(gsub("\\[.*", paste0("|trunc(lb=", lower, ", ub=", upper, ")"), y))
  }
  x <- parsed_form$x
  individual <- parsed_form$individual
  group <- parsed_form$group
  USEGROUP <- parsed_form$USEG
  USEINDIVIDUAL <- parsed_form$USEID
  df <- parsed_form$data
  hierarchical_predictor <- parsed_form$hierarchical_predictor

  #* `convert group to character to avoid unexpected factor stuff`
  df[[group]] <- as.character(df[[group]])
  #* `Make autocorrelation formula`
  if (USEINDIVIDUAL) {
    corForm <- as.formula(paste0("~arma(~", x, "|", individual, ":", group, ",1,1)"))
  } else {
    corForm <- NULL
  }
  #* `get family specific elements`
  family_res <- .brmFamilyHelper(model)
  model <- family_res$rhs
  family <- family_res$family
  dpars <- family_res$dpars
  #* `Reformat sigma if it is a formula`
  sigma <- .sigmaHelper(sigma, dpars, family, models)
  #* `match args`
  matchGrowthModelRes <- .matchGrowthModel(model, models)
  matched_model <- matchGrowthModelRes[["model"]]
  decay <- matchGrowthModelRes[["decay"]]
  #* `Make growth formula`
  nTimes <- min(unlist(lapply(split(df, df[[group]]), function(d) {
    length(unique(d[[x]]))
  }))) # for spline knots
  splineHelperForm <- NULL
  if (grepl("\\+", model)) {
    chngptHelperList <- .brmsChangePointHelper(model, x, y, group,
      dpar = FALSE, nTimes = nTimes,
      useGroup = USEGROUP, priors = priors, int = int
    )
    growthForm <- chngptHelperList$growthForm
    pars <- chngptHelperList$pars
    splineHelperForm <- chngptHelperList$splineHelperForm
  } else {
    matched_model <- gsub("homo", "int", matched_model)
    matched_model <- gsub("spline", "gam", matched_model)

    stringBrmsFormFun <- paste0(".brms_form_", gsub(" ", "", matched_model))
    brmsFormFun <- match.fun(stringBrmsFormFun)
    formRes <- brmsFormFun(x, y, group,
      dpar = FALSE, nTimes = nTimes,
      useGroup = USEGROUP, prior = priors, int = int
    )
    if (decay) {
      formRes <- .brms_form_decay(formRes, int)
    }
    pars <- formRes$pars
    growthForm <- formRes$form
  }

  #* `Make distributional parameter formulas`
  #* Note there is always a sigma after .sigmaHelper (it just might be homoskedastic)
  dpar_res <- lapply(seq_along(sigma), function(i) {
    dpar <- names(sigma)[[i]]
    model <- sigma[[i]]
    intModelRes <- .intModelHelper(model)
    model <- intModelRes$model
    sigmaInt <- intModelRes$int
    .brmDparHelper(dpar, model, x, group, nTimes, USEGROUP, priors, sigmaInt)
  })
  names(dpar_res) <- names(sigma)
  dparForm <- unlist(lapply(dpar_res, function(res) {
    res$dparForm
  }))
  dparSplineHelperForm <- unlist(lapply(dpar_res, function(res) {
    res$dparSplineHelperForm
  }))
  dpar_pars <- unlist(lapply(dpar_res, function(res) {
    res$dpar_pars
  }))
  names(dpar_pars) <- NULL
  pars <- append(pars, dpar_pars)
  pars <- pars[!grepl("spline", pars)]

  #* `Make hierarchical parameter model formulas`
  if (!is.null(hierarchical_predictor)) {
    if (is.null(hierarchy)) {
      warning(paste0(
        "hierarchy argument not provided, assuming linear models with intercepts ",
        "for all ", matched_model, " model parameters (",
        paste(pars, collapse = ", "),
        ")."
      ))
      hierarchy <- lapply(pars, function(p) {
        "int_linear"
      })
      names(hierarchy) <- pars
    }

    hrc_res <- lapply(names(hierarchy), function(pname) {
      hrc_model <- hierarchy[[pname]]
      intModelRes <- .intModelHelper(hrc_model)
      hrc_model <- intModelRes$model
      hrc_int <- intModelRes$int
      .brmDparHelper(
        dpar = pname, model = hrc_model, x = hierarchical_predictor,
        group, nTimes, USEGROUP, priors, int = hrc_int
      )
      #* here passing `pname` to the `dpar` argument of .brmDparHelper will make
      #* .brmDparHelper add that name as a prefix on all of the existing model parameters.
      #* Since all the parameter names are unique coming into this they will be unique coming
      #* out of this as well.
      #* I'm also passing hierarchical_predictor to the x argument
    })
    names(hrc_res) <- names(hierarchy)
    hrcForm <- unlist(lapply(hrc_res, function(res) {
      res$dparForm
    }))
    hrcSplineHelperForm <- unlist(lapply(hrc_res, function(res) {
      res$dparSplineHelperForm
    }))
    hrc_pars <- unlist(lapply(hrc_res, function(res) {
      res$dpar_pars
    }))
    names(hrc_pars) <- NULL
    pars <- append(pars, hrc_pars)
    pars <- pars[-which(pars %in% names(hierarchy))] #* remove pars that are now estimated by other
    #* sub models from the later steps.
  } else {
    hrcForm <- NULL
    hrcSplineHelperForm <- NULL
  }
  pars <- pars[!grepl("spline", pars)]

  #* `Make parameter grouping formulae`

  if (!is.null(pars)) {
    if (USEGROUP) {
      parForm <- as.formula(paste0(paste(pars, collapse = "+"), "~0+", group))
    } else {
      parForm <- as.formula(paste0(paste(pars, collapse = "+"), "~1"))
    }
  } else {
    parForm <- NULL
  }

  #* `Combine formulas into brms.formula object`
  if (is.null(parForm)) {
    NL <- FALSE
  } else {
    NL <- TRUE
  }
  bf_args <- list(
    "formula" = growthForm, dparForm, hrcForm, parForm,
    dparSplineHelperForm, hrcSplineHelperForm, splineHelperForm,
    "autocor" = corForm, "nl" = NL
  )
  bf_args <- bf_args[!unlist(lapply(bf_args, is.null))]
  bayesForm <- do.call(brms::bf, args = bf_args)

  out[["formula"]] <- bayesForm
  #* ***** `Make priors` *****
  out[["prior"]] <- .makePriors(priors, pars, df, group, USEGROUP, sigma, family, bayesForm)
  #* ***** `Make initializer function` *****
  if (!is.null(pars)) {
    initFun <- function(pars = "?", nPerChain = 1) {
      init <- lapply(pars, function(i) array(rgamma(nPerChain, 1)))
      names(init) <- paste0("b_", pars)
      init
    }
    formals(initFun)$pars <- pars
    formals(initFun)$nPerChain <- length(unique(df[[group]]))
    wrapper <- function() {
      initFun()
    }
  } else {
    wrapper <- 0
  }

  #* ***** `Raise Message for complex models` *****

  if (length(pars) * length(unique(df[[group]])) > 50) {
    message(paste0(
      "This model will estimate >50 parameters (excluding any smooth terms). \n\n",
      "If the MCMC is very slow then consider fitting separate models and using `combineDraws()` ",
      "to make a data.frame for hypothesis testing."
    ))
  }

  #* ***** `Return Components` *****
  out[["initfun"]] <- wrapper
  out[["df"]] <- df
  out[["family"]] <- family
  out[["pcvrForm"]] <- form
  return(out)
}

#' Function to visualize brms survival models specified using growthSS.
#'
#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
#' (and similar models made through other means)
#'  can be visualized easily using this function. This will generally be called by \code{growthPlot}.
#'
#' @param fit A brmsfit object, similar to those fit with \code{\link{growthSS}} outputs.
#' @param form A formula similar to that in \code{growthSS} inputs specifying the outcome,
#' predictor, and grouping structure of the data as \code{outcome ~ predictor|individual/group}.
#' @param df An optional dataframe to use in plotting observed growth curves on top of the model.
#' @param groups An optional set of groups to keep in the plot.
#' Defaults to NULL in which case all groups in the model are plotted.
#' @param timeRange An optional range of times to use. This can be used to view predictions for
#' future data if the available data has not reached some point (such as asymptotic size),
#' although prediction using splines outside of the observed range is not necessarily reliable.
#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
#' @import ggplot2
#' @import viridis
#' @importFrom stats as.formula
#' @examples
#' \donttest{
#' set.seed(123)
#' df <- growthSim("exponential",
#'   n = 20, t = 50,
#'   params = list("A" = c(1, 1), "B" = c(0.15, 0.1))
#' )
#' ss1 <- growthSS(
#'   model = "survival weibull", form = y > 100 ~ time | id / group,
#'   df = df, start = c(0, 5)
#' )
#' fit1 <- fitGrowth(ss1, iter = 600, cores = 2, chains = 2, backend = "cmdstanr")
#' brmSurvPlot(fit1, form = ss1$pcvrForm, df = ss1$df)
#'
#' # note that using the cumulative hazard to calculate survival is likely to underestimate
#' # survival in these plots if events do not start immediately.
#' ss2 <- growthSS(
#'   model = "survival binomial", form = y > 100 ~ time | id / group,
#'   df = df, start = c(-4, 3)
#' )
#' fit2 <- fitGrowth(ss2, iter = 600, cores = 2, chains = 2, backend = "cmdstanr")
#' brmSurvPlot(fit2, form = ss2$pcvrForm, df = ss2$df)
#' }
#'
#' @return Returns a ggplot showing a brms model's credible
#' intervals and optionally the individual growth lines.
#'
#' @export

brmSurvPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE) {
  family <- as.character(fit$family)[1]

  if (family == "weibull") {
    p <- .weibullBrmSurvPlot(
      fit = fit, form = form, df = df, groups = groups,
      timeRange = timeRange, facetGroups = facetGroups
    )
  } else if (family == "binomial") {
    p <- .binomialBrmSurvPlot(
      fit = fit, form = form, df = df, groups = groups,
      timeRange = timeRange, facetGroups = facetGroups
    )
  }
  return(p)
}

#' Internal Plotting function for weibull survival times
#' brms predicts mu where: scale = exp(mu) / (gamma(1 + 1 / shape))
#' @keywords internal
#' @noRd

.binomialBrmSurvPlot <- function(fit, form, df = NULL, groups = NULL,
                                 timeRange = NULL, facetGroups = TRUE) {
  #* `pull model data`
  fitData <- fit$data
  #* `general pcvr formula parsing`
  parsed_form <- .parsePcvrForm(form, df)
  x <- parsed_form$x
  group <- parsed_form$group
  df <- parsed_form$data
  #* `set groups to use`
  if (is.null(groups)) {
    groups <- unique(fitData[[group]])
  }
  #* `pull draws and convert to survival`
  draws <- as.matrix(fit)
  s_hat <- brms::inv_logit_scaled(draws[, grepl("^b_", colnames(draws))])
  colnames(s_hat) <- gsub("b_", "haz_", colnames(s_hat))
  s_hat <- 1 - s_hat # take complement of hazard
  s_hat <- as.data.frame(
    do.call(rbind, lapply(groups, function(grp) {
      s_hat_grp <- s_hat[, grepl(paste0(group, grp, "$"), colnames(s_hat))]
      x <- do.call(cbind, lapply(seq_len(ncol(s_hat_grp)), function(j) {
        do.call(rbind, lapply(seq_len(nrow(s_hat_grp)), function(i) {
          cumprod(s_hat_grp[i, 1:j])[j]
        }))
      }))
      colnames(x) <- gsub("haz_", "surv_", colnames(s_hat_grp))
      colnames(x) <- gsub(paste0(":", group, grp), "", colnames(x))
      x <- as.data.frame(x)
      x[[group]] <- grp
      x
    }))
  )

  #* `define probabilities and take quantiles`
  probs <- seq(from = 99, to = 1, by = -2) / 100
  quantiles <- as.data.frame(
    do.call(rbind, lapply(groups, function(grp) {
      s_hat_grp <- s_hat[s_hat[[group]] == grp, ]
      grp_quantile <- as.data.frame(do.call(rbind, lapply(1:(ncol(s_hat_grp) - 1), function(i) {
        quantile(s_hat_grp[, i], probs)
      })))
      colnames(grp_quantile) <- paste0("Q", seq(99, 1, -2))
      nms <- colnames(s_hat_grp)[grepl("surv_", colnames(s_hat_grp))]
      grp_quantile[[x]] <- as.numeric(gsub(paste0("surv_", x), "", nms))
      grp_quantile[[group]] <- grp
      grp_quantile
    }))
  )
  quantiles <- quantiles[quantiles[[group]] %in% groups, ]
  #* `Decide faceting`
  facetLayer <- NULL
  if (facetGroups && length(unique(fitData[[group]])) > 1) {
    facetLayer <- ggplot2::facet_wrap(as.formula(paste0("~", group)))
  }
  #* `lengthen quantiles`
  max_prime <- 0.99
  min_prime <- 0.01
  max_obs <- 49
  min_obs <- 1
  c1 <- (max_prime - min_prime) / (max_obs - min_obs)

  longPreds <- do.call(rbind, lapply(seq_len(nrow(quantiles)), function(r) {
    sub <- quantiles[r, ]
    do.call(rbind, lapply(seq(1, 49, 2), function(i) {
      min <- paste0("Q", i)
      max <- paste0("Q", 100 - i)
      iter <- sub[, c(x, group)]
      iter$q <- round(1 - (c1 * (i - max_obs) + max_prime), 2)
      iter$min <- sub[[min]]
      iter$max <- sub[[max]]
      iter
    }))
  }))

  #* `Initialize Plot`
  p <- ggplot2::ggplot(longPreds, ggplot2::aes(x = .data[[x]])) +
    facetLayer +
    ggplot2::labs(x = x, y = "Survival") +
    ggplot2::scale_y_continuous(labels = scales::label_percent()) +
    pcv_theme()
  #* `Add Ribbons`
  p <- p +
    lapply(unique(longPreds$q), function(q) {
      ggplot2::geom_ribbon(
        data = longPreds[longPreds$q == q, ],
        ggplot2::aes(
          ymin = min,
          ymax = max,
          group = .data[[group]],
          fill = q
        ), alpha = 0.5
      )
    }) +
    viridis::scale_fill_viridis(direction = -1, option = "plasma") +
    ggplot2::labs(fill = "Credible\nInterval")

  #* `Add KM Trend`
  if (!is.null(df)) {
    df$pct_surv <- (1 - df$pct_event)
    df[[x]] <- as.numeric(df[[x]])
    p <- p + ggplot2::geom_line(data = df, ggplot2::aes(
      x = .data[[x]],
      y = .data[["pct_surv"]],
      group = .data[[group]],
      linetype = .data[[group]]
    ), color = "black", show.legend = FALSE)
  }
  return(p)
}


#' Internal Plotting function for weibull survival times
#' brms predicts mu where: scale = exp(mu) / (gamma(1 + 1 / shape))
#' @keywords internal
#' @noRd

.weibullBrmSurvPlot <- function(fit, form, df = NULL, groups = NULL,
                                timeRange = NULL, facetGroups = TRUE) {
  #* `Transform draws`
  fitData <- fit$data
  fdf <- as.data.frame(fit)
  mu_cols <- colnames(fdf)[grepl("b_", colnames(fdf))]
  scales <- do.call(cbind, lapply(mu_cols, function(col) {
    exp(fdf[[col]]) / (gamma(1 + (1 / fdf$shape)))
  }))
  colnames(scales) <- paste0("scale_", mu_cols)
  fdf <- cbind(fdf, scales)
  #* `general pcvr formula parsing`
  parsed_form <- .parsePcvrForm(form, df)
  x <- parsed_form$x
  group <- parsed_form$group
  df <- parsed_form$data
  #* `further survival formula steps`

  #* `Define Time Range`
  if (is.null(timeRange)) {
    timeRange <- seq(0, round(max(fitData[[x]]), -1), length.out = 100)
  }
  #* `set groups to use`
  if (is.null(groups)) {
    groups <- unique(fitData[[group]])
  }
  #* `Make Survival Quantiles`
  probs <- seq(from = 99, to = 1, by = -2) / 100
  quantiles <- do.call(rbind, lapply(groups, function(grp) {
    test <- fdf[, c(paste0("scale_b_", group, grp), "shape")]
    colnames(test) <- c("scale", "shape")
    metrics <- do.call(rbind, lapply(probs, function(i) {
      shape <- quantile(test[, "shape"], probs = i)
      scale <- quantile(test[, "scale"], probs = i)
      do.call(rbind, lapply(timeRange, function(t) {
        t_row <- data.frame(
          probs = i,
          h = shape / scale * (t / scale)^(shape - 1),
          cdf = 1 - exp(1)^-(t / scale)^shape,
          pdf = shape / scale * (t / scale)^(shape - 1) * exp(1)^-(t / scale)^shape
        )
        t_row[[x]] <- t
        t_row$St <- 1 - t_row$cdf
        t_row$c <- -log(t_row$St)
        t_row
      }))
    }))

    metrics$probs2 <- round(metrics$probs * 100, 2)
    metrics <- data.table::as.data.table(metrics)
    wide_metrics <- as.data.frame(data.table::dcast(metrics, time ~ paste0("Q", probs2),
      value.var = "St", fun.aggregate = mean
    ))
    wide_metrics[[group]] <- grp
    wide_metrics
  }))
  #* `Decide faceting`
  facetLayer <- NULL
  if (facetGroups && length(unique(fitData[[group]])) > 1) {
    facetLayer <- ggplot2::facet_wrap(as.formula(paste0("~", group)))
  }
  #* `lengthen quantiles`
  max_prime <- 0.99
  min_prime <- 0.01
  max_obs <- 49
  min_obs <- 1
  c1 <- (max_prime - min_prime) / (max_obs - min_obs)

  longPreds <- do.call(rbind, lapply(seq_len(nrow(quantiles)), function(r) {
    sub <- quantiles[r, ]
    do.call(rbind, lapply(seq(1, 49, 2), function(i) {
      min <- paste0("Q", i)
      max <- paste0("Q", 100 - i)
      iter <- sub[, c("time", group)]
      iter$q <- round(1 - (c1 * (i - max_obs) + max_prime), 2)
      iter$min <- sub[[min]]
      iter$max <- sub[[max]]
      iter
    }))
  }))
  #* `Initialize Plot`
  p <- ggplot2::ggplot(longPreds, ggplot2::aes(x = .data[["time"]])) +
    facetLayer +
    ggplot2::labs(x = x, y = "Survival") +
    ggplot2::scale_y_continuous(labels = scales::label_percent()) +
    pcv_theme()
  #* `Add Ribbons`
  p <- p +
    lapply(unique(longPreds$q), function(q) {
      ggplot2::geom_ribbon(
        data = longPreds[longPreds$q == q, ],
        ggplot2::aes(
          ymin = min,
          ymax = max,
          group = .data[[group]],
          fill = q
        ), alpha = 0.5
      )
    }) +
    viridis::scale_fill_viridis(direction = -1, option = "plasma") +
    ggplot2::labs(fill = "Credible\nInterval")
  #* `Add KM Trend`
  if (!is.null(df)) {
    km_df <- do.call(rbind, lapply(groups, function(grp) {
      sub <- df[df[[group]] == grp, ]
      do.call(rbind, lapply(timeRange, function(ti) {
        sum_events <- sum(c(sub[as.numeric(sub[[x]]) <= ti, "event"], 0))
        n_at_risk <- nrow(sub) - sum_events
        surv_pct <- n_at_risk / nrow(sub)
        data.frame(
          group = grp, time = ti, events = sum_events,
          at_risk = n_at_risk, surv_pct = surv_pct
        )
      }))
    }))
    p <- p + ggplot2::geom_line(data = km_df, ggplot2::aes(
      x = .data[["time"]],
      y = .data[["surv_pct"]],
      group = .data[["group"]],
      linetype = .data[["group"]]
    ), color = "black", show.legend = FALSE)
  }
  return(p)
}

#' @description
#' Internal function for testing conjugate methods for MV and SV traits, useful for testing only.
#' @param method a conjugate method with mv and sv options
#' @param prior A prior for that conjugate method
#' @param generating a list similar to those for mvSim that will generate data. See example.
#' @examples
#' method = "vonmises"
#' prior = list(mu = 0, kappa = 1, known_kappa = 1, boundary = c(0, 180), n = 1)
#' generating = list(
#'   s1 = list(f = "rnorm", n = 20, mean = 20, sd = 5),
#'   s2 = list(f = "rnorm", n = 20, mean = 170, sd = 5)
#' )
#' .conjugate.mv.sv.testing(method, prior, generating)
#'
#' @keywords internal
#' @noRd

.conjugate.mv.sv.testing <- function(method, prior, generating) {
  s1 <- do.call(generating[[1]][[1]], generating[[1]][-1])
  s2 <- do.call(generating[[2]][[1]], generating[[2]][-1])

  dists1 <- stats::setNames(list(generating[[1]][-1]), generating[[1]][[1]])
  m1 <- mvSim(dists1, n_samples = generating[[1]]$n)[, -1]
  dists2 <- stats::setNames(list(generating[[2]][-1]), generating[[2]][[1]])
  m2 <- mvSim(dists2, n_samples = generating[[2]]$n)[, -1]

  ps <- conjugate(s1, s2, method = method, priors = prior, plot = FALSE, cred.int.level = 0.95)
  pm <- conjugate(m1, m2, method = method, priors = prior, plot = FALSE, cred.int.level = 0.95)
  ps$posterior[[1]]$datatype <- "sv"
  ps$posterior[[2]]$datatype <- "sv"
  pm$posterior[[1]]$datatype <- "mv"
  pm$posterior[[2]]$datatype <- "mv"
  ps$summary$datatype <- "sv"
  pm$summary$datatype <- "mv"
  posteriors <- do.call(rbind, c(ps$posterior, pm$posterior))
  summaries <- rbind(ps$summary, pm$summary)
  data_used <- list(sv_s1 = s1, sv_s2 = s2, mv_s1 = m1, mv_s2 = m2)
  return(list("posteriors" = posteriors, "summaries" = summaries, "data_used" = data_used))
}

#' Function to visualize \code{flexsurv::flexsurvreg} models fit by \code{fitGrowth}.
#'
#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
#' (and similar models made through other means) can be visualized easily using this function.
#' This will generally be called by \code{growthPlot}.
#'
#' @param fit A model fit returned by \code{fitGrowth} with type="nls".
#' @param form A formula similar to that in \code{growthSS} inputs
#' (or the \code{pcvrForm} part of the output) specifying the outcome,
#' predictor, and grouping structure of the data as \code{outcome ~ predictor|individual/group}.
#' If the individual and group are specified then the observed growth lines are plotted.
#' @param groups An optional set of groups to keep in the plot.
#' Defaults to NULL in which case all groups in the model are plotted.
#' @param df A dataframe to use in plotting observed growth curves on top of the model.
#' This must be supplied for nls models.
#' @param timeRange Ignored, included for compatibility with other plotting functions.
#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
#' @param groupFill logical, should groups have different colors? Defaults to FALSE. If TRUE then
#' viridis colormaps are used in the order of virMaps
#' @param virMaps order of viridis maps to use. Will be recycled to necessary length.
#' Defaults to "plasma", but will generally be informed by growthPlot's default.
#' @keywords survival
#' @importFrom methods is
#' @import ggplot2
#' @importFrom stats predict
#' @examples
#'
#' df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "survival weibull", form = y > 100 ~ time | id / group,
#'   df = df, type = "flexsurv"
#' )
#' fit <- fitGrowth(ss)
#' flexsurvregPlot(fit, form = ss$pcvrForm, df = ss$df, groups = "a")
#' flexsurvregPlot(fit,
#'   form = ss$pcvrForm, df = ss$df,
#'   facetGroups = FALSE, groupFill = TRUE
#' )
#'
#' @return Returns a ggplot showing an survival model's survival function.
#'
#' @export


flexsurvregPlot <- function(fit, form, groups = NULL, df = NULL, timeRange = NULL, facetGroups = TRUE,
                            groupFill = FALSE, virMaps = c("plasma")) {
  #* `parse formula`
  parsed_form <- .parsePcvrForm(form, df)
  x <- parsed_form$x
  group <- parsed_form$group
  df <- parsed_form$data
  #* `filter by groups if groups != NULL`
  if (!is.null(groups)) {
    df <- df[df[[group]] %in% groups, ]
  } else {
    groups <- unique(df[[group]])
  }
  #* `generate predictions`
  pct <- seq(0.01, 0.99, 0.01)
  preds <- predict(fit,
    newdata = data.frame("group" = groups),
    type = "quantile", p = pct, se.fit = TRUE
  )
  preds <- do.call(rbind, lapply(seq_along(preds[[1]]), function(i) {
    iter <- as.data.frame(preds[[1]][[i]])
    colnames(iter) <- c("pct", "est", "se")
    iter[[group]] <- groups[i]
    iter
  }))
  preds$surv <- 1 - preds$pct
  #* `facetGroups`
  if (facetGroups) {
    facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
  } else {
    facet_layer <- NULL
  }
  #* `groupFill`
  if (groupFill) {
    virVals <- lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
      viridis::viridis(3, begin = 0.1, option = pal)
    })
    names(virVals) <- groups
    color_scale <- ggplot2::scale_color_manual(values = unlist(lapply(virVals, function(pal) pal[3])))
  } else {
    virVals <- lapply(rep("plasma", length.out = length(unique(df[[group]]))), function(pal) {
      viridis::viridis(3, begin = 0.1, option = pal)
    })
    names(virVals) <- groups
    color_scale <- ggplot2::scale_color_manual(values = unlist(lapply(virVals, function(pal) pal[3])))
  }
  #* `Make ggplot`
  p <- ggplot2::ggplot(preds, ggplot2::aes(
    x = .data[["est"]],
    y = .data[["surv"]], group = .data[[group]]
  )) +
    facet_layer +
    lapply(groups, function(grp) {
      ggplot2::geom_ribbon(data = preds[preds[[group]] == grp, ], ggplot2::aes(
        xmin = .data[["est"]] - (2 * .data[["se"]]),
        xmax = .data[["est"]] + (2 * .data[["se"]])
      ), fill = virVals[[grp]][1], alpha = 0.5)
    }) +
    lapply(groups, function(grp) {
      ggplot2::geom_ribbon(data = preds[preds[[group]] == grp, ], ggplot2::aes(
        xmin = .data[["est"]] - (1 * .data[["se"]]),
        xmax = .data[["est"]] + (1 * .data[["se"]])
      ), fill = virVals[[grp]][2], alpha = 0.5)
    }) +
    ggplot2::geom_line(ggplot2::aes(color = .data[[group]]), show.legend = FALSE) +
    color_scale +
    ggplot2::scale_y_continuous(labels = scales::label_percent()) +
    ggplot2::labs(x = x, y = "Survival") +
    pcv_theme()


  if (!is.null(df)) {
    km_df <- do.call(rbind, lapply(groups, function(grp) {
      sub <- df[df[[group]] == grp, ]
      do.call(rbind, lapply(seq(0, max(df[[x]]), 1), function(ti) {
        sum_events <- sum(c(sub[as.numeric(sub[[x]]) <= ti, "event"], 0))
        n_at_risk <- nrow(sub) - sum_events
        surv_pct <- n_at_risk / nrow(sub)
        iter <- data.frame(
          group = grp, time = ti, events = sum_events,
          at_risk = n_at_risk, surv_pct = surv_pct
        )
        colnames(iter)[1] <- group
        iter
      }))
    }))
    p <- p + ggplot2::geom_line(data = km_df, ggplot2::aes(
      x = .data[[x]],
      y = .data[["surv_pct"]],
      group = .data[[group]],
      linetype = .data[[group]]
    ), color = "black")
  }

  return(p)
}

#' Function for plotting iterations of posterior distributions
#'
#' @param fits A list of brmsfit objects following the same data over time.
#'    Currently checkpointing is not supported.
#' @param form A formula describing the growth model similar to \code{\link{growthSS}}
#'    and \code{\link{brmPlot}} such as: outcome ~ predictor |individual/group
#' @param df data used to fit models (this is used to plot each subject's trend line).
#' @param priors a named list of samples from the prior distributions for each parameter in
#'     \code{params}. This is only used if sample_prior=FALSE in the brmsfit object.
#'     If left NULL then no prior is included.
#' @param params a vector of parameters to include distribution plots of.
#'     Defaults to NULL which will use all parameters from the top level model.
#' @param maxTime Optional parameter to designate a max time not observed in the models so far
#' @param patch Logical, should a patchwork plot be returned or should lists of ggplots be returned?
#' @keywords Bayesian brms
#' @import ggplot2
#' @import patchwork
#' @importFrom methods is
#' @importFrom stats setNames
#' @import viridis
#' @return A ggplot or a list of ggplots (depending on patch).
#' @export
#' @examples
#' \donttest{
#' print(load(url("https://raw.githubusercontent.com/joshqsumner/pcvrTestData/main/brmsFits.rdata")))
#' library(brms)
#' library(ggplot2)
#' library(patchwork)
#' fits <- list(fit_3, fit_15)
#' form <- y~time | id / group
#' priors <- list(
#'   "phi1" = rlnorm(2000, log(130), 0.25),
#'   "phi2" = rlnorm(2000, log(12), 0.25),
#'   "phi3" = rlnorm(2000, log(3), 0.25)
#' )
#' params <- c("A", "B", "C")
#' d <- simdf
#' maxTime <- NULL
#' patch <- TRUE
#' from3to25 <- list(
#'   fit_3, fit_5, fit_7, fit_9, fit_11,
#'   fit_13, fit_15, fit_17, fit_19, fit_21, fit_23, fit_25
#' )
#' distributionPlot(
#'   fits = from3to25, form = y ~ time | id / group,
#'   params = params, d = d, priors = priors, patch = FALSE
#' )
#' distributionPlot(
#'   fits = from3to25, form = y ~ time | id / group,
#'   params = params, d = d, patch = FALSE
#' )
#' }
#' ## End(Not run)
distributionPlot <- function(fits, form, df, priors = NULL,
                             params = NULL, maxTime = NULL, patch = TRUE) {
  #* ***** `Reused helper variables`
  parsed_form <- .parsePcvrForm(form, df)
  y <- parsed_form$y
  x <- parsed_form$x
  individual <- parsed_form$individual
  group <- parsed_form$group
  d <- parsed_form$data
  fitData <- fits[[length(fits)]]$data
  dSplit <- split(d, d[[group]])
  startTime <- min(unlist(lapply(fits, function(ft) {
    min(ft$data[[x]], na.rm = TRUE)
  })))
  if (is.null(maxTime)) {
    endTime <- max(unlist(lapply(fits, function(ft) {
      max(ft$data[[x]], na.rm = TRUE)
    })))
  }
  byTime <- mean(diff(unlist(lapply(fits, function(ft) {
    max(ft$data[[x]], na.rm = TRUE)
  }))))
  timeRange <- seq(startTime, endTime, byTime)
  virOptions <- c("C", "G", "B", "D", "A", "H", "E", "F")
  palettes <- lapply(
    seq_along(unique(fitData[[group]])),
    function(i) {
      viridis::viridis(length(timeRange),
        begin = 0.1,
        end = 1, option = virOptions[i], direction = 1
      )
    }
  )
  names(palettes) <- unique(fitData[[group]])

  #* ***** `if params is null then pull them from growth formula`

  if (is.null(params)) {
    fit <- fits[[1]]
    growthForm <- as.character(fit$formula[[1]])[[3]]

    test <- gsub(x, "", growthForm) # ;test
    test2 <- gsub("exp\\(", "", test) # ; test2
    test3 <- gsub("\\(1", "", test2) # ;test3
    test4 <- gsub("[/]|[+]|[-]|[)]|[()]", "", test3)
    params <- strsplit(test4, "\\s+")[[1]]


    test3 <- gsub("[)]|[()]", "", test2)
    test3
  }

  #* ***** `growth trendline plots`

  growthTrendPlots <- lapply(seq_along(dSplit), function(i) {
    dt <- dSplit[[i]]
    ggplot2::ggplot(dt, ggplot2::aes(
      x = .data[[x]], y = .data[[y]], color = .data[[x]],
      group = .data[[individual]]
    )) +
      ggplot2::geom_line(show.legend = FALSE) +
      viridis::scale_color_viridis(begin = 0.1, end = 1, option = virOptions[i], direction = 1) +
      ggplot2::scale_x_continuous(limits = c(startTime, endTime)) +
      pcv_theme()
  })

  #* ***** `posterior distribution extraction`

  posts <- do.call(rbind, lapply(fits, function(fit) {
    time <- max(fit$data[[x]], na.rm = TRUE)
    fitDraws <- do.call(cbind, lapply(params, function(par) {
      draws <- as.data.frame(fit)[grepl(par, colnames(as.data.frame(fit)))]
      if (nrow(brms::prior_draws(fit)) > 1) {
        draws <- draws[!grepl("^prior_", colnames(draws))]
      }
      splits <- strsplit(colnames(draws), split = "")
      mx <- max(unlist(lapply(splits, length)))
      ind <- which(unlist(lapply(1:mx, function(i) {
        length(unique(rapply(splits, function(j) {
          j[i]
        }))) != 1
      })))
      if (length(ind) > 0) {
        colnames(draws) <- paste(par, unlist(lapply(colnames(draws), function(c) {
          substr(c, min(ind), max(c(ind, nchar(c))))
        })), sep = "_")
      }
      draws
    }))
    fitDraws$time <- time
    fitDraws
  }))

  #* ***** `prior distribution extraction`
  distPlotPriorExtractionRes <- .distPlotPriorExtraction(fits, priors, d, group, params, x)
  prior_df <- distPlotPriorExtractionRes[["prior_df"]]
  USEPRIOR <- distPlotPriorExtractionRes[["UP"]]

  #* ***** `posterior distribution plots`
  #* need to assign ordering of factors
  #* if USEPRIOR then join data, don't make separate geom

  if (USEPRIOR) {
    posts <- rbind(prior_df, posts)
  }
  posts[[x]] <- factor(posts[[x]], levels = sort(as.numeric(unique(posts[[x]]))), ordered = TRUE)

  lapply(posts, summary)

  xlims <- lapply(params, function(par) {
    diff <- as.numeric(as.matrix(posts[, grepl(paste0("^", par, "_"), colnames(posts))]))
    c(min(diff, na.rm = TRUE), max(diff, na.rm = TRUE))
  })
  names(xlims) <- params
  postPlots <- lapply(unique(fitData[[group]]), function(groupVal) {
    groupPlots <- lapply(params, function(par) {
      p <- ggplot2::ggplot(posts) +
        ggplot2::geom_density(ggplot2::aes(
          x = .data[[paste(par, groupVal, sep = "_")]],
          fill = .data[[x]], color = .data[[x]],
          group = .data[[x]]
        ), alpha = 0.8) +
        ggplot2::labs(x = paste(par, group, groupVal)) +
        ggplot2::coord_cartesian(xlim = xlims[[par]]) +
        pcv_theme() +
        ggplot2::theme(
          axis.text.x.bottom = ggplot2::element_text(angle = 0),
          legend.position = "none", axis.title.y = ggplot2::element_blank()
        )

      if (USEPRIOR) {
        p <- p + ggplot2::scale_fill_manual(values = c("black", palettes[[groupVal]])) +
          ggplot2::scale_color_manual(values = c("black", palettes[[groupVal]]))
      } else {
        p <- p + ggplot2::scale_fill_manual(values = palettes[[groupVal]]) +
          ggplot2::scale_color_manual(values = palettes[[groupVal]])
      }
      return(p)
    })
    return(groupPlots)
  })

  if (patch) {
    ncol_patch <- 1 + length(params)
    nrow_patch <- length(postPlots)

    patchPlot <- growthTrendPlots[[1]] + postPlots[[1]]
    if (length(unique(d[[group]])) > 1) {
      for (i in 2:length(growthTrendPlots)) {
        patchPlot <- patchPlot + growthTrendPlots[[i]] + postPlots[[i]]
      }
    }
    out <- patchPlot + patchwork::plot_layout(ncol = ncol_patch, nrow = nrow_patch)
  } else {
    out <- list(growthTrendPlots, postPlots)
  }
  return(out)
}

#' Prior extraction in distPlot
#' @keywords internal
#' @noRd

.distPlotPriorExtraction <- function(fits, priors, d, group, params, x) {
  if (is.null(priors)) {
    return(list("prior_df" = NULL, "UP" = FALSE))
  }
  if (all(unlist(lapply(fits, function(fit) nrow(brms::prior_draws(fit)) < 1)))) {
    # if no models were fit with sample_prior
    if (!is.null(priors)) { # if prior is supplied as argument
      USEPRIOR <- TRUE
      if (!methods::is(priors[[1]], "list")) {
        priors <- lapply(seq_along(unique(d[[group]])), function(i) priors)
        names(priors) <- unique(d[[group]])
      }
      prior_df <- do.call(cbind, lapply(names(priors), function(nm) {
        nmp <- priors[[nm]]
        setNames(data.frame(do.call(cbind, lapply(names(nmp), function(nmpn) {
          nmp[[nmpn]]
        }))), paste0(names(nmp), "_", nm))
      }))
      prior_df[[x]] <- 0
    } else {
      USEPRIOR <- FALSE
    }
  } else { #* `need to fit some models with sample_prior and see how this works with them`
    prior_df <- brms::prior_draws(fits[[1]])
    prior_df <- prior_df[, grepl(paste0("b_", paste0(params, collapse = "|")), colnames(prior_df))]
    colnames(prior_df) <- gsub(group, "", colnames(prior_df))
    colnames(prior_df) <- gsub("^b_", "", colnames(prior_df))
    prior_df[[x]] <- 0
    USEPRIOR <- TRUE
  }
  return(list("prior_df" = prior_df, "UP" = USEPRIOR))
}

#' Function to parse survival model specifications in growthSS for brms type models
#'
#' @param model a survival distribution to use (currently "binomial" and "weibull" are supported)
#' @param form a formula in pcvr syntax
#' @param df a dataframe to use
#' @param priors priors specified per details in growthSS
#'
#' @return A list of elements to pass to fitGrowth
#'
#' @examples
#' set.seed(123)
#' model = "survival weibull"
#' form <- y > 100 ~ time | id / group
#' df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' surv <- .survModelParser(model)
#' survivalBool <- surv$survival
#' model <- surv$model
#' prior <- c(0, 5)
#' ss <- .brmsSurvSS(model, form, df, prior)
#' lapply(ss, head)
#'
#' @keywords internal
#' @noRd

.brmsSurvSS <- function(model = NULL, form = NULL, df = NULL, priors = NULL) {
  out <- list()
  #* `make survival data`
  fixData <- TRUE
  if (grepl("binomial", model)) {
    if (all(c("n_events", "n_eligible") %in% colnames(df))) {
      fixData <- FALSE
    }
  } else { # weibull
    if (all(c("event", "censor") %in% colnames(df))) {
      fixData <- FALSE
    }
  }
  if (fixData) {
    makeSurvDataRet <- .makeSurvData(df, form, model)
    out_df <- makeSurvDataRet$data
    out[["df"]] <- out_df
  } else {
    makeSurvDataRet <- list()
    getGroup <- trimws(strsplit(as.character(form)[3], "[|]|[/]")[[1]])
    makeSurvDataRet$group <- getGroup[length(getGroup)]
    makeSurvDataRet$x <- getGroup[1]
    out_df <- df
    out[["df"]] <- out_df
  }

  #* `make bayesian formula`
  if (model == "binomial") {
    form_ret <- .brmsurv_binomial_formula(
      x = makeSurvDataRet$x, group = makeSurvDataRet$group,
      df = out_df
    )
  } else if (model == "weibull") {
    form_ret <- .brmsurv_weibull_formula(
      x = makeSurvDataRet$x, group = makeSurvDataRet$group,
      df = out_df
    )
  }
  out[["family"]] <- form_ret$family
  out[["formula"]] <- form_ret$formula
  #* `make priors if none specified`
  out[["prior"]] <- .brmsMakeSurvPriors(priors, out_df, makeSurvDataRet, form_ret)
  #* `set initialization to 0 for all chains`
  out[["initfun"]] <- 0
  out[["pcvrForm"]] <- form
  return(out)
}


#' Helper function to make priors for brms survival models
#' @return A list with a formula and a model family
#' @keywords internal
#' @noRd

.brmsMakeSurvPriors <- function(priors, out_df, makeSurvDataRet, form_ret) {
  if (is.null(priors)) {
    return(brms::prior_string("normal(0, 5)", class = "b"))
  } else if (any(methods::is(priors, "brmsprior"))) {
    return(priors)
  } else if (is.numeric(priors)) {
    priors <- rep(priors, length.out = 2 * length(unique(out_df[[makeSurvDataRet$group]])))
    priors <- stats::setNames(
      lapply(seq(1, length(priors), 2), function(i) {
        c(priors[i], priors[i + 1])
      }),
      unique(out_df[[makeSurvDataRet$group]])
    )
    message(
      "Prior is numeric, replicating to ", length(unique(out_df[[makeSurvDataRet$group]])),
      " length 2 elements (mu, sd) and assuming order ",
      paste(unique(out_df[[makeSurvDataRet$group]]),
        collapse = ", "
      )
    )
  }
  pars <- brms::get_prior(formula = form_ret$formula, data = out_df, family = form_ret$family)$coef
  pars <- pars[which(nchar(pars) > 0)]
  if (length(priors) != length(pars)) {
    message(paste0(
      "Priors and parameters are not the same length. Output will assume that priors are for groups",
      " and are in order: ", paste(unique(out_df[[makeSurvDataRet$group]]), collapse = ", ")
    ))
    priors <- stats::setNames(
      rep(priors, length.out = length(unique(out_df[[makeSurvDataRet$group]]))),
      unique(out_df[[makeSurvDataRet$group]])
    )
  }
  prior_obj <- NULL
  for (g in unique(out_df[[makeSurvDataRet$group]])) {
    sub_pars <- pars[grepl(paste0(makeSurvDataRet$group, g), pars)]
    for (param in sub_pars) {
      if (is.null(prior_obj)) {
        prior_obj <- brms::set_prior(
          prior = paste0("normal(", priors[[g]][1], ",", priors[[g]][2], ")"),
          coef = param
        )
      } else {
        prior_obj <- prior_obj + brms::set_prior(
          prior = paste0("normal(", priors[[g]][1], ",", priors[[g]][2], ")"),
          coef = param
        )
      }
    }
  }
  return(prior_obj)
}


#' Helper function to make formulas for brms binomial survival models
#' @return A list with a formula and a model family
#' @keywords internal
#' @noRd

.brmsurv_binomial_formula <- function(y = "n_events", x = "time", total = "n_eligible",
                                      group = "groups", df = NULL) {
  #* make formula
  if (is.null(group) || length(unique(df[[group]])) == 1) {
    formula <- stats::as.formula(paste0(y, " | trials(", total, ") ~ 0 + ", x))
  } else {
    formula <- stats::as.formula(paste0(y, " | trials(", total, ") ~ 0 + ", x, ":", group))
  }
  #* specify family
  family <- "binomial" # using default links
  return(list("formula" = formula, "family" = family))
}

#' Helper function to make formulas for brms weibull survival models
#' @return A list with a formula and a model family
#' @keywords internal
#' @noRd

.brmsurv_weibull_formula <- function(y = "event", x = "time", censor = "censor",
                                     group = "groups", df = NULL) {
  #* make formula
  if (is.null(group) || length(unique(df[[group]])) == 1) {
    formula <- stats::as.formula(paste0(x, " | cens(", censor, ") ~ 1"))
  } else {
    formula <- stats::as.formula(paste0(x, " | cens(", censor, ") ~ 0 + ", group))
  }
  #* specify family
  family <- "weibull" # using default links
  return(list("formula" = formula, "family" = family))
}




#' Function to parse survival model specifications in growthSS for modeling in the survival package
#'
#' @return a list of components passed to fitGrowth
#'
#' @examples
#'
#' set.seed(123)
#' model = "survival weibull"
#' form <- y > 100 ~ time | id / group
#' df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' surv <- .survModelParser(model)
#' survivalBool <- surv$survival
#' model <- surv$model
#' ss <- .survSS(model, form, df)
#' lapply(ss, head)
#'
#' @importFrom survival survreg Surv
#'
#' @keywords internal
#' @noRd

.survSS <- function(model = NULL, form = NULL, df = NULL) {
  out <- list()
  #* `make survival data`
  fixData <- TRUE
  if (all(c("event") %in% colnames(df))) {
    fixData <- FALSE
  }
  if (fixData) {
    makeSurvDataRet <- .makeSurvData(df, form, model = "weibull")
    out_df <- makeSurvDataRet$data
    out_df[[makeSurvDataRet$group]] <- factor(out_df[[makeSurvDataRet$group]])
    out_df[[paste0(makeSurvDataRet$group, "_numericLabel")]] <- unclass(out_df[[makeSurvDataRet$group]])
    out[["df"]] <- out_df
  } else {
    makeSurvDataRet <- list()
    getGroup <- trimws(strsplit(as.character(form)[3], "[|]|[/]")[[1]])
    makeSurvDataRet$group <- getGroup[length(getGroup)]
    makeSurvDataRet$x <- getGroup[1]
    out[["df"]] <- df
  }
  #* `make survreg formula`
  x <- makeSurvDataRet$x
  group <- makeSurvDataRet$group
  if (is.null(group) || length(unique(df[[group]])) == 1) {
    formula <- stats::as.formula(paste0("Surv(", x, ", event) ~ 1"))
  } else {
    formula <- stats::as.formula(paste0("Surv(", x, ", event) ~ 1 + group"))
  }
  out[["formula"]] <- formula
  #* `return all`
  out[["pcvrForm"]] <- form
  out[["distribution"]] <- model
  return(out)
}


#' Function to parse survival model specifications in growthSS for modeling in the flexsurv package
#'
#' @return a list of components passed to fitGrowth
#'
#' @examples
#'
#' set.seed(123)
#' model = "survival gengamma"
#' form <- y > 100 ~ time | id / group
#' df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' surv <- .survModelParser(model)
#' survivalBool <- surv$survival
#' model <- surv$model
#' ss <- .flexSurvSS(model, form, df)
#' lapply(ss, head)
#'
#' @importFrom survival survreg Surv
#'
#' @keywords internal
#' @noRd

.flexSurvSS <- function(model = NULL, form = NULL, df = NULL, anc = NULL) {
  out <- list()
  distributions <- c(
    "gengamma", "gengamma.orig", "genf", "genf.orig",
    "weibull", "gamma", "exp", "llogis", "lnorm", "gompertz",
    "exponential", "lognormal"
  )
  if (!model %in% distributions) {
    stop(paste0(
      "Supported distributions for flexsurv models are ",
      paste(distributions, collapse = ", "),
      ".\nIf you are using a custom distribution please call flexsurvreg directly."
    ))
  }
  #* `make survival data`
  fixData <- TRUE
  if (all(c("event") %in% colnames(df))) {
    fixData <- FALSE
  }
  if (fixData) {
    makeSurvDataRet <- .makeSurvData(df, form, model = "weibull")
    out_df <- makeSurvDataRet$data
    out_df[[makeSurvDataRet$group]] <- factor(out_df[[makeSurvDataRet$group]])
    out_df[[paste0(makeSurvDataRet$group, "_numericLabel")]] <- unclass(out_df[[makeSurvDataRet$group]])
    out[["df"]] <- out_df
  } else {
    makeSurvDataRet <- list()
    getGroup <- trimws(strsplit(as.character(form)[3], "[|]|[/]")[[1]])
    makeSurvDataRet$group <- getGroup[length(getGroup)]
    makeSurvDataRet$x <- getGroup[1]
    out[["df"]] <- df
  }
  #* `make main survival formula`
  x <- makeSurvDataRet$x
  group <- makeSurvDataRet$group
  if (is.null(group) || length(unique(df[[group]])) == 1) {
    formula <- stats::as.formula(paste0("Surv(", x, ", event) ~ 1"))
  } else {
    formula <- stats::as.formula(paste0("Surv(", x, ", event) ~ 1 + group"))
  }
  out[["formula"]][["f1"]] <- formula
  #* `collect additional formulas`
  if (!is.null(anc)) {
    out[["formula"]][["f2"]] <- anc
  } else {
    out[["formula"]][["f2"]] <- NULL
  }

  #* `return all`
  out[["pcvrForm"]] <- form
  out[["distribution"]] <- model
  return(out)
}

#' Ease of use nlrq starter function for 6 growth model parameterizations
#'
#' Internal to growthSS
#'
#' @examples
#'
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#'
#' ss <- .mgcvSS(model = "gam", form = y ~ time | id / group, df = simdf)
#' names(ss) # formula, df, pcvrForm
#'
#' @keywords internal
#' @noRd

.mgcvSS <- function(model = "gam", form, df) {
  #* `parse form argument`
  parsed_form <- .parsePcvrForm(form, df)
  y <- parsed_form$y
  x <- parsed_form$x
  group <- parsed_form$group
  USEGROUP <- parsed_form$USEG
  if (parsed_form$USEID) {
    message(paste0("Individual is not used with type = 'gam'."))
  }
  df <- parsed_form$data

  if (USEGROUP) {
    df[[group]] <- factor(df[[group]])
    df[[paste0(group, "_numericLabel")]] <- unclass(df[[group]])
  }
  #* `assemble gam formula`
  if (USEGROUP) {
    gam_form <- stats::as.formula(paste0(y, "~0+", group, "+s(", x, ", by=", group, ")"))
  } else {
    gam_form <- stats::as.formula(paste0(y, "~0+s(", x, ")"))
  }
  #* `return list`
  out <- list()
  out[["formula"]] <- gam_form
  out[["df"]] <- df
  out[["pcvrForm"]] <- form
  return(out)
}

#' Remove outliers from bellwether data using cook's distance
#'
#' @param df Data frame to use. Can be in long or wide format.
#' @param phenotype Column to use to classify outliers. If this is length > 1 then
#' it is taken as the multi-value traits to use. See examples.
#' @param naTo0 Logical, should NA values to changed to 0.
#' @param group  Grouping variables to find outliers as a character vector.
#' This is typically time  and design variables (DAS, genotype, treatment, etc).
#' These are used as predictors for `phenotype` in a generalized linear model.
#' @param cutoff Cutoff for something being an "outlier" expressed as a multiplier
#'  on the mean of Cooks Distance for this data. This defaults to 5, with higher values
#'  being more conservative (removing less of the data).
#' @param outlierMethod Method to be used in detecting outliers.
#'  Currently "cooks" and "mahalanobis" distances are supported, with "mahalanobis" only
#'  being supported for multi-value traits.
#' @param plotgroup Grouping variables for drawing plots if plot=TRUE.
#' Typically this is an identifier for images of a plant
#' over time and defaults to c('barcode',"rotation").
#' @param plot Logical, if TRUE then a list is returned with a ggplot and a dataframe.
#' @param x Optional specification for x axis variable if plot is true.
#' If left NULL (the default) then the first element of `group` is used.
#' @param traitCol Column with phenotype names, defaults to "trait".
#' This should generally not need to be changed from the default.
#'    If this and valueCol are present in colnames(df) then the data
#'    is assumed to be in long format.
#' @param valueCol Column with phenotype values, defaults to "value".
#' This should generally not need to be changed from the default.
#' @param labelCol Column with phenotype labels for long data, defaults to "label".
#' This should generally not need to be changed from the default.
#' @param idCol Column(s) that identify individuals over time.
#' Defaults to plotGroup.
#' @param ncp Optionally specify the number of principle components to be used for MV data outlier
#' detection with cooks distance. If left NULL (the default) then 3 will be used.
#' @param separate Optionally separate the data by some variable to speed up the modeling step.
#' If you have a design variable with
#' very many levels then it may be helpful to separate by that variable.
#' Note this will subset the data for each model so it will change
#' the outlier removal (generally to be more conservative).
#' @keywords ggplot outliers
#' @import ggplot2
#' @import data.table
#' @importFrom stats complete.cases cooks.distance glm as.formula lm mahalanobis cov
#' @examples
#'
#'
#' sv <- growthSim("logistic",
#'   n = 5, t = 20,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' sv[130, ]$y <- 500
#' sv_res <- bw.outliers(
#'   df = sv, phenotype = "y", naTo0 = FALSE, cutoff = 15,
#'   group = c("time", "group"), outlierMethod = "cooks",
#'   plotgroup = "id", plot = TRUE
#' )
#' sv_res$plot
#' \donttest{
#' library(data.table)
#' mvw <- read.pcv(paste0(
#'   "https://media.githubusercontent.com/media/joshqsumner/",
#'   "pcvrTestData/main/pcv4-multi-value-traits.csv"
#' ), mode = "wide", reader = "fread")
#' mvw$genotype <- substr(mvw$barcode, 3, 5)
#' mvw$genotype <- ifelse(mvw$genotype == "002", "B73",
#'   ifelse(mvw$genotype == "003", "W605S",
#'     ifelse(mvw$genotype == "004", "MM", "Mo17")
#'   )
#' )
#' mvw$fertilizer <- substr(mvw$barcode, 8, 8)
#' mvw$fertilizer <- ifelse(mvw$fertilizer == "A", "100",
#'   ifelse(mvw$fertilizer == "B", "50", "0")
#' )
#' mvw <- bw.time(mvw, timeCol = "timestamp", group = "barcode", plot = FALSE)
#'
#' phenotypes <- which(grepl("hue_freq", colnames(mvw)))
#'
#' mvw2 <- bw.outliers(
#'   df = mvw, phenotype = phenotypes, naTo0 = FALSE, outlierMethod = "cooks",
#'   group = c("DAS", "genotype", "fertilizer"), cutoff = 3, plotgroup = c("barcode", "rotation")
#' )
#'
#'
#' mvl <- read.pcv(paste0(
#'   "https://media.githubusercontent.com/media/joshqsumner/",
#'   "pcvrTestData/main/pcv4-multi-value-traits.csv"
#' ), mode = "long")
#' mvl$genotype <- substr(mvl$barcode, 3, 5)
#' mvl$genotype <- ifelse(mvl$genotype == "002", "B73",
#'   ifelse(mvl$genotype == "003", "W605S",
#'     ifelse(mvl$genotype == "004", "MM", "Mo17")
#'   )
#' )
#' mvl$fertilizer <- substr(mvl$barcode, 8, 8)
#' mvl$fertilizer <- ifelse(mvl$fertilizer == "A", "100",
#'   ifelse(mvl$fertilizer == "B", "50", "0")
#' )
#' mvl <- bw.time(mvl, timeCol = "timestamp", group = "barcode", plot = FALSE)
#'
#' mvl2 <- bw.outliers(
#'   df = mvl, phenotype = "hue_frequencies", naTo0 = FALSE, outlierMethod = "cooks",
#'   group = c("DAS", "genotype", "fertilizer"), cutoff = 3, plotgroup = c("barcode", "rotation")
#' )
#' }
#'
#' @return The input dataframe with outliers removed and optionally a plot
#' (if a plot is returned then output is a list).
#' @export


bw.outliers <- function(df = NULL,
                        phenotype,
                        naTo0 = FALSE,
                        group = c(),
                        cutoff = 3,
                        outlierMethod = "cooks",
                        plotgroup = c("barcode", "rotation"),
                        plot = TRUE, x = NULL, traitCol = "trait", valueCol = "value",
                        labelCol = "label", idCol = NULL, ncp = NULL, separate = NULL) {
  wide <- .detectWideData(df, traitCol, valueCol)
  if (is.null(phenotype)) {
    stop("A phenotype must be provided")
  }

  if ((wide && length(phenotype) > 1) ||
    (!wide && length(unique(
      interaction(df[df[[traitCol]] == phenotype, colnames(df) %in% c(traitCol, labelCol)])
    )) > 1)) {
    mv <- TRUE
  } else {
    mv <- FALSE
  }

  if (is.null(idCol)) {
    idCol <- plotgroup
  }

  if (!is.null(separate)) {
    dfList <- split(df, df[[separate]])
    group <- group[!grepl(separate, group)]
  } else {
    dfList <- list(df)
  }

  resList <- .applyOutlierMethod(
    dfList, wide, mv, outlierMethod,
    naTo0, phenotype, group, cutoff,
    ncp, traitCol, valueCol, labelCol, idCol
  )

  df <- do.call(rbind, lapply(resList, function(res) {
    res[["data"]]
  }))
  pctRm <- do.call(rbind, lapply(seq_along(resList), function(i) {
    data.frame(i = i, pctRm = resList[[i]][["pctRm"]])
  }))

  out <- df[which(!df$outlier), -which(grepl("outlier", colnames(df)))]

  removedInteractions <- do.call(rbind, lapply(
    resList,
    function(d) {
      tab <- as.data.frame(table(d$data[, c(separate, group)]))
      colnames(tab) <- c(separate, group, "Freq")
      return(tab[tab$Freq == 0, ])
    }
  ))
  if (nrow(removedInteractions) > 0) {
    warning(paste0(nrow(removedInteractions), " groupings had all observations removed"))
  }

  if (plot) {
    p <- .outlierPlottingHelper(wide, mv, df, plotgroup, group, x, phenotype, traitCol, valueCol, pctRm)
    out <- list("data" = out, "plot" = p)
  }

  return(out)
}


#' ***********************************************************************************************
#' *************** `Apply outlier methods` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function to apply outlier methods
#'
#' @keywords internal
#' @noRd

.applyOutlierMethod <- function(dfList, wide, mv, outlierMethod,
                                naTo0, phenotype, group, cutoff,
                                ncp, traitCol, valueCol, labelCol, idCol) {
  resList <- lapply(dfList, function(df) {
    mv_label <- if (mv) {
      "mv"
    } else {
      "sv"
    }
    wide_label <- if (wide) {
      ".wide"
    } else {
      ".long"
    }
    matched_fun <- get(paste(wide_label, mv_label, outlierMethod, "outliers", sep = "_"))
    res <- matched_fun(df, naTo0, phenotype, group, cutoff, ncp, traitCol, valueCol, labelCol, idCol)
    return(res)
  })
  return(resList)
}


#' ***********************************************************************************************
#' *************** `wide data detection` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for outlier detection in wide SV data.
#'
#' @keywords internal
#' @noRd

.detectWideData <- function(df, traitCol, valueCol) {
  if (all(c(traitCol, valueCol) %in% colnames(df))) {
    wide <- FALSE
  } else {
    wide <- TRUE
  }
  return(wide)
}


#' ***********************************************************************************************
#' *************** `plotting helper` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for outlier detection in wide SV data.
#'
#' @keywords internal
#' @noRd

.outlierPlottingHelper <- function(wide, mv, df, plotgroup, group,
                                   x, phenotype, traitCol, valueCol, pctRm) {
  if (is.null(x)) {
    x <- group[1]
  }
  if (wide && !mv) {
    df$grouping <- interaction(df[, plotgroup])
    outPlotData <- df[!df$outlier, ]
    rmdfPlotData <- df[df$outlier, ]
    p <- ggplot2::ggplot() +
      ggplot2::facet_wrap(stats::as.formula(paste0("~", paste(group[-1], collapse = "+")))) +
      ggplot2::geom_line(data = df, ggplot2::aes(
        x = .data[[x]], y = .data[[phenotype]],
        group = .data[["grouping"]]
      ), linewidth = 0.25) +
      ggplot2::labs(title = paste0("~", round(mean(pctRm$pctRm), 3), "% Removed")) +
      pcv_theme()

    yLims <- ggplot2::layer_scales(p)$y$range$range

    p <- p +
      ggplot2::geom_point(
        data = rmdfPlotData, ggplot2::aes(
          x = .data[[x]],
          y = .data[[phenotype]]
        ),
        color = "red", size = 0.5
      ) +
      ggplot2::coord_cartesian(ylim = yLims)
  } else if (!wide && !mv) {
    plotdf <- df[df[[traitCol]] == phenotype, ]
    plotdf$grouping <- interaction(plotdf[, plotgroup])
    outPlotData <- plotdf[!plotdf$outlier, ]
    rmdfPlotData <- plotdf[plotdf$outlier, ]
    p <- ggplot2::ggplot() +
      ggplot2::facet_wrap(stats::as.formula(paste0("~", paste(group[-1], collapse = "+")))) +
      ggplot2::geom_line(data = plotdf, ggplot2::aes(
        x = .data[[x]], y = .data[[valueCol]],
        group = .data[["grouping"]]
      ), linewidth = 0.25) +
      ggplot2::labs(title = paste0("~", round(mean(pctRm$pctRm), 3), "% Removed")) +
      pcv_theme()

    yLims <- ggplot2::layer_scales(p)$y$range$range

    p <- p +
      ggplot2::geom_point(
        data = rmdfPlotData, ggplot2::aes(
          x = .data[[x]],
          y = .data[[valueCol]]
        ),
        color = "red", size = 0.5
      ) +
      ggplot2::coord_cartesian(ylim = yLims)
  } else if (wide && mv) {
    plotdf <- suppressWarnings(
      as.data.frame(
        data.table::melt(data.table::as.data.table(df),
          measure.vars = phenotype,
          variable.name = traitCol,
          value.name = valueCol
        )
      )
    )

    plotdf$bin <- as.numeric(regmatches(plotdf$trait, regexpr("[0-9]+", plotdf$trait)))

    plotdf$grouping <- interaction(plotdf[, plotgroup])
    outPlotData <- plotdf[!plotdf$outlier, ]
    rmdfPlotData <- plotdf[plotdf$outlier, ]

    p <- ggplot2::ggplot() +
      ggplot2::facet_wrap(stats::as.formula(paste0("~", paste(group[-1], collapse = "+")))) +
      ggplot2::geom_col(
        data = rmdfPlotData, ggplot2::aes(x = .data[["bin"]], y = .data[[valueCol]]),
        position = "identity",
        fill = "red", alpha = 0.25
      ) +
      ggplot2::geom_col(
        data = outPlotData, ggplot2::aes(x = .data[["bin"]], y = .data[[valueCol]]),
        position = "identity",
        alpha = 0.25
      ) +
      ggplot2::labs(title = paste0("~", round(mean(pctRm$pctRm), 3), "% Removed")) +
      pcv_theme()
  } else if (!wide && mv) {
    plotdf <- df
    plotdf$grouping <- interaction(plotdf[, plotgroup])
    outPlotData <- plotdf[!plotdf$outlier, ]
    rmdfPlotData <- plotdf[plotdf$outlier, ]

    p <- ggplot2::ggplot() +
      ggplot2::facet_wrap(stats::as.formula(paste0("~", paste(group[-1], collapse = "+")))) +
      ggplot2::geom_col(
        data = rmdfPlotData, ggplot2::aes(x = .data[[traitCol]], y = .data[[valueCol]]),
        position = "identity",
        fill = "red", alpha = 0.25
      ) +
      ggplot2::geom_col(
        data = outPlotData, ggplot2::aes(x = .data[[traitCol]], y = .data[[valueCol]]),
        position = "identity",
        alpha = 0.25
      ) +
      ggplot2::labs(title = paste0("~", round(mean(pctRm$pctRm), 3), "% Removed")) +
      pcv_theme()
  }
  return(p)
}


#' ***********************************************************************************************
#' *************** `wide SV cooks distance` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for outlier detection in wide SV data.
#'
#' @keywords internal
#' @noRd

.wide_sv_cooks_outliers <- function(df, naTo0, phenotype, group, cutoff, ncp,
                                    traitCol, valueCol, labelCol, idCol) {
  if (naTo0) {
    df[[phenotype]][is.na(df[[phenotype]])] <- 0
  }
  df <- df[complete.cases(df[, c(phenotype, group)]), ]
  outlierForm <- paste("as.numeric(", phenotype, ")~", paste(paste0("as.factor(", group, ")"),
    collapse = ":"
  ))
  cooksd <- cooks.distance(glm(data = df, as.formula(outlierForm)))
  outlierCutoff <- cutoff * mean(cooksd, na.rm = TRUE)
  cooksd[is.na(cooksd)] <- outlierCutoff - 0.1 # keeping NAs
  cooksd_df <- data.frame("outlier" = cooksd)
  df <- cbind(df, cooksd_df)
  df$outlier <- df$outlier > outlierCutoff
  pctRm <- 100 * (round(nrow(df[df$outlier, ]) / nrow(df), 5))

  return(list("data" = df, "pctRm" = pctRm))
}


#' ***********************************************************************************************
#' *************** `long SV cooks distance` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for outlier detection in wide SV data.
#'
#' @keywords internal
#' @noRd

.long_sv_cooks_outliers <- function(df, naTo0, phenotype, group, cutoff, ncp,
                                    traitCol, valueCol, labelCol, idCol) {
  if (naTo0) {
    df[df[[traitCol]] == phenotype, valueCol][is.na(df[df[[traitCol]] == phenotype, valueCol])] <- 0
  }
  subdf <- df[complete.cases(df[
    df[[traitCol]] == phenotype,
    c(valueCol, traitCol, group)
  ]) & df[[traitCol]] == phenotype, ]
  outlierForm <- paste("as.numeric(", valueCol, ")~", paste(paste0("as.factor(", group, ")"),
    collapse = ":"
  ))
  cooksd <- cooks.distance(glm(data = subdf, as.formula(outlierForm)))
  outlierCutoff <- cutoff * mean(cooksd, na.rm = TRUE)
  cooksd[is.na(cooksd)] <- outlierCutoff - 0.1 # keeping NAs by assigning a value below cutoff.
  cooksd_df <- data.frame("outlier" = cooksd)
  subdf <- cbind(subdf, cooksd_df)
  subdf <- subdf[, c(group, idCol, "outlier")]
  subdf <- subdf[!duplicated(subdf[, c(group, idCol)]), ]
  subdf$outlier <- subdf$outlier > outlierCutoff
  pctRm <- 100 * (round(nrow(subdf[subdf$outlier, ]) / nrow(subdf), 5))
  #* take IDs using plotgroup and label all phenotype rows
  df <- merge(df, subdf, all.x = TRUE)
  return(list("data" = df, "pctRm" = pctRm))
}

#' ***********************************************************************************************
#' *************** `wide MV cooks distance` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for outlier detection in wide MV data.
#'
#' @keywords internal
#' @noRd

.wide_mv_cooks_outliers <- function(df, naTo0, phenotype, group, cutoff, ncp,
                                    traitCol, valueCol, labelCol, idCol) {
  if (naTo0) {
    df[, phenotype][is.na(df[, phenotype])] <- 0
  }

  phenos_df <- df[, phenotype]
  if (is.null(ncp)) {
    ncp <- min(min(dim(phenos_df)) - 1, 3)
  }
  pca <- FactoMineR::PCA(phenos_df, ncp = ncp, graph = FALSE)
  coords <- as.data.frame(pca$ind)
  coords <- coords[, grepl("coord", colnames(coords))]
  colnames(coords) <- gsub("coord.Dim.", "pc", colnames(coords))
  pca_cols <- colnames(coords)
  df <- cbind(df, coords)

  df <- df[complete.cases(df[, c(pca_cols, group)]), ]

  outlierForm <- paste(
    "cbind(", paste0("pc", 1:ncp, collapse = ","), ")~",
    paste(paste0("as.factor(", group, ")"), collapse = ":")
  )
  cooksd <- cooks.distance(lm(data = df, as.formula(outlierForm)))

  df <- df[, -which(colnames(df) %in% c(paste0("pc", 1:ncp)))]

  if (length(cutoff) == 1) {
    cutoff <- rep(cutoff, ncp)
  }
  outlierCutoffs <- cutoff * colMeans(cooksd, na.rm = TRUE)

  outlierMatrix <- do.call(cbind, lapply(seq_len(ncol(cooksd)), function(i) {
    cooks_vec <- cooksd[, i] # this is causing a problem
    cooks_vec[is.na(cooks_vec)] <- outlierCutoffs[i] - 0.1
    setNames(data.frame(cooks_vec > outlierCutoffs[i]), paste0("outlier_", i))
  }))
  outlierMatrix$outlier <- unlist(lapply(seq_len(nrow(outlierMatrix)), function(i) {
    any(outlierMatrix[i, ]) # could be a more nuanced rule
  }))

  df <- cbind(df, outlierMatrix)
  pctRm <- 100 * (round(nrow(df[df$outlier, ]) / nrow(df), 5))
  return(list("data" = df, "pctRm" = pctRm))
}


#' ***********************************************************************************************
#' *************** `long MV cooks distance` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for outlier detection in long MV data.
#'
#' @keywords internal
#' @noRd

.long_mv_cooks_outliers <- function(df, naTo0, phenotype, group, cutoff, ncp,
                                    traitCol, valueCol, labelCol, idCol) {
  #* widen data
  dcast_form <- as.formula(paste0("... ~ ", traitCol, "+", labelCol))
  dfw <- as.data.frame(data.table::dcast(data.table::as.data.table(df[df[[traitCol]] == phenotype, ]),
    dcast_form,
    value.var = valueCol, sep = "."
  ))
  phenotypew <- which(grepl(phenotype, colnames(dfw)))
  #* call .wide method on dfw
  wide_res <- .wide_mv_cooks_outliers(dfw, naTo0, phenotypew, group, cutoff, ncp)
  pctRm <- wide_res[["pctRm"]]
  sub_df <- wide_res[["data"]]
  #* label long data based on .wide output
  kept <- unique(as.character(interaction(sub_df[!sub_df$outlier, c(group, idCol)])))
  df_ids <- as.character(interaction(df[, c(group, idCol)]))
  df$outlier <- !df_ids %in% kept

  return(list("data" = df, "pctRm" = pctRm))
}

#' ***********************************************************************************************
#' *************** `wide MV mahalanobis distance` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for outlier detection in wide MV data.
#'
#' @keywords internal
#' @noRd


.wide_mv_mahalanobis_outliers <- function(df, naTo0, phenotype, group, cutoff, ncp,
                                          traitCol, valueCol, labelCol, idCol) {
  if (naTo0) {
    df[, phenotype][is.na(df[, phenotype])] <- 0
  }

  phenos_df <- df[, phenotype]
  phenos_df <- phenos_df[, colSums(phenos_df) > 1]
  mahala_center <- colMeans(phenos_df, na.rm = TRUE)
  mahala_cov <- stats::cov(phenos_df)
  m <- stats::mahalanobis(phenos_df, mahala_center, mahala_cov)

  df$mahal <- m
  group_inter <- unique(as.character(interaction(df[, group])))

  df_out <- do.call(rbind, lapply(group_inter, function(grp) {
    subMeta <- df[interaction(df[, group]) == grp, ]
    subMeta$outlier <- ifelse(subMeta$mahal > cutoff * mean(subMeta$mahal, na.rm = TRUE), TRUE, FALSE)
    subMeta
  }))

  pctRm <- 100 * (round(nrow(df_out[df_out$outlier, ]) / nrow(df_out), 5))

  return(list("data" = df_out, "pctRm" = pctRm))
}

#' ***********************************************************************************************
#' *************** `long MV mahalanobis distance` ****************************************
#' ***********************************************************************************************
#' @description
#' Internal function for outlier detection in long MV data.
#'
#' @keywords internal
#' @noRd

.long_mv_mahalanobis_outliers <- function(df, naTo0, phenotype, group, cutoff,
                                          ncp, traitCol, valueCol, labelCol, idCol) {
  #* widen data
  dcast_form <- as.formula(paste0("... ~ ", traitCol, "+", labelCol))
  dfw <- as.data.frame(data.table::dcast(data.table::as.data.table(df[df[[traitCol]] == phenotype, ]),
    dcast_form,
    value.var = valueCol, sep = "."
  ))
  phenotypew <- which(grepl(phenotype, colnames(dfw)))
  #* call .wide method on dfw
  wide_res <- .wide_mv_mahalanobis_outliers(dfw, naTo0, phenotypew, group, cutoff)
  pctRm <- wide_res[["pctRm"]]
  sub_df <- wide_res[["data"]]
  #* label long data based on .wide output
  kept <- unique(as.character(interaction(sub_df[!sub_df$outlier, c(group, idCol)])))
  df_ids <- as.character(interaction(df[, c(group, idCol)]))
  df$outlier <- !df_ids %in% kept

  return(list("data" = df, "pctRm" = pctRm))
}

#' Ease of use multi-value trait model helper function.
#'
#' This function provides a simplified interface to modeling multi-value traits using \link{growthSS}.
#' Output from this should be passed to \link{fitGrowth} to fit the specified model.
#'
#' @param form A formula similar to \code{label | value ~ time + id/group} where label is a column
#' of histogram bins, value is the counts within those bins, time is an optional time variable,
#' id identifies an individual, and group contains the treatment groups.
#' @param sigma Distributional models passed to \link{growthSS}.
#' @param df Data passed to \link{growthSS}.
#' @param pars Parameters to vary, passed to \link{growthSS}.
#' @param start Starting values or priors, passed to \link{growthSS}.
#' @param type Backend to use, passed to \link{growthSS}.
#' @param tau Quantile to model, passed to \link{growthSS}.
#' @param hierarchy Formulae describing any hierarchical models, see \link{growthSS}.
#' @param spectral_index Optionally, a spectral index
#' \href{https://plantcv.readthedocs.io/en/stable/spectral_index/}{from those calculated by PlantCV}.
#' If this is given then the appropriate truncation and model family (if applicable)
#' will be included for the index you are using without you having to write it in the formula.
#' @keywords multi-value
#' @return A named list of plots showing prior distributions that \code{growthSS} would use,
#' optionally with a plot of simulated growth curves using draws from those priors.
#'
#' @examples
#' set.seed(123)
#' mv_df <- mvSim(dists = list(rnorm = list(mean = 100, sd = 30)), wide = FALSE)
#' mv_df$group <- rep(c("a", "b"), times = 900)
#' mv_df <- mv_df[mv_df$value > 0, ]
#' mv_df$label <- as.numeric(gsub("sim_", "", mv_df$variable))
#'
#' ss1 <- mvSS(
#'   model = "linear", form = label | value ~ group, df = mv_df,
#'   start = list("A" = 5), type = "brms", spectral_index = "ci_rededge"
#' )
#' \donttest{
#' mod1 <- fitGrowth(ss1, backend = "cmdstanr", iter = 1000, chains = 1, cores = 1)
#' growthPlot(mod1, ss1$pcvrForm, df = ss1$df)
#' }
#'
#' # when the model is longitudinal the same model is possible with growthSS
#'
#' m1 <- mvSim(
#'   dists = list(
#'     rnorm = list(mean = 100, sd = 30),
#'     rnorm = list(mean = 110, sd = 25),
#'     rnorm = list(mean = 120, sd = 20),
#'     rnorm = list(mean = 135, sd = 15)
#'   ),
#'   wide = FALSE, n = 6
#' )
#' m1$time <- rep(1:4, times = 6 * 180)
#' m2 <- mvSim(
#'   dists = list(
#'     rnorm = list(mean = 85, sd = 25),
#'     rnorm = list(mean = 95, sd = 20),
#'     rnorm = list(mean = 105, sd = 15),
#'     rnorm = list(mean = 110, sd = 15)
#'   ),
#'   wide = FALSE, n = 6
#' )
#' m2$time <- rep(1:4, times = 6 * 180)
#' mv_df2 <- rbind(m1, m2)
#' mv_df2$group <- rep(c("a", "b"), each = 4320)
#' mv_df2 <- mv_df2[mv_df2$value > 0, ]
#' mv_df2$label <- as.numeric(gsub("sim_", "", mv_df2$variable))
#'
#' ss_mv1 <- mvSS(
#'   model = "linear", form = label | value ~ time | group, df = mv_df2,
#'   start = list("A" = 50), type = "brms", spectral_index = "ci_rededge"
#' )
#' ss_mv2 <- growthSS(
#'   model = "skew_normal: linear",
#'   form = label | resp_weights(value) + trunc(lb = -1, ub = Inf) ~ time | group,
#'   df = mv_df2, start = list("A" = 50)
#' )
#' identical(names(ss_mv1), names(ss_mv2))
#' # ignoring environments and other such details these are identical except for the
#' # function call.
#' unlist(lapply(names(ss_mv1), function(nm) {
#'   if (!identical(ss_mv1[[nm]], ss_mv2[[nm]],
#'     ignore.environment = TRUE,
#'     ignore.srcref = TRUE
#'   )) {
#'     if (!identical(as.character(ss_mv1[[nm]]), as.character(ss_mv2[[nm]]))) {
#'       nm
#'     }
#'   }
#' }))
#'
#' \donttest{
#' m2 <- fitGrowth(ss_mv1, backend = "cmdstanr", iter = 1000, chains = 1, cores = 1)
#' growthPlot(m2, ss_mv1$pcvrForm, df = ss_mv1$df)
#' }
#'
#' @export

mvSS <- function(model = "linear", form, sigma = NULL, df, start = NULL,
                 pars = NULL, type = "brms", tau = 0.5, hierarchy = NULL,
                 spectral_index = c(
                   "none", "ari", "ci_rededge", "cri550", "cri700",
                   "egi", "evi", "gdvi", "mari", "mcari", "mtci", "ndre",
                   "ndvi", "pri", "psnd_chlorophyll_a", "psnd_chlorophyll_b",
                   "psnd_caroteniods", "psri", "pssr_chlorophyll_a",
                   "pssr_chlorophyll_b", "pssr_caroteniods", "rgri",
                   "rvsi", "savi", "sipi", "sr", "vari", "vi_green", "wi",
                   "fvfm", "fqfm"
                 )) {
  #* `get spectral index helper function`
  #* spectral index function should just return truncation and family, then there will be a separate
  #* function that applies those changes to the form argument.
  pcvrForm <- form
  spec_helper <- get(paste0(".", spectral_index, "_mvss_hlp"))
  #* `run spectral index helper function`
  spec_helper_res <- spec_helper()
  family <- spec_helper_res$family
  trunc <- spec_helper_res$trunc
  #* `run formula cleaner`
  #* This should return the final, usable formula and model
  form_res <- .mv_ss_formula_builder(form, family, trunc, type, model, df)
  form <- form_res$formula
  weights <- form_res$weights
  model <- form_res$model
  df <- form_res$df
  has_x_var <- form_res$has_x_var
  if (has_x_var) {
    #* `if time is a variable, call growthSS with new model formula`
    out <- growthSS(
      model = model, form = form, sigma = sigma, df = df, start = start,
      pars = pars, type = type, tau = tau, hierarchy = hierarchy
    )
  } else {
    #* `if x variable is missing then call mvSS_helpers to make simple model`
    #* this is the tricky part I think. but on the other hand if time is missing then it's
    #* really only one option for what happens next, so maybe it's not bad. Model is basically
    #* ignored in this case.
    form_fun <- get(paste0(".", type, "_mvss"))
    out <- form_fun(form, df, start, family, model, tau, weights, pcvrForm)
  }
  out$call <- match.call()
  return(out)
}


#' `mvSS_formula_builder`
#' add family, truncation, and weights to formula
#' @keywords internal
#' @noRd

.mv_ss_formula_builder <- function(form, family, trunc, type, model, df) {
  form_char <- as.character(form)
  has_x_var <- TRUE
  parsed <- .parsePcvrForm(form, df)
  df <- parsed$data
  if (!is.numeric(df[, parsed$x]) && !parsed$USEG && !parsed$USEID) {
    has_x_var <- FALSE # treating single element of RHS as grouping
  }
  weights <- NULL
  #* for brms backend make weights in formula
  if (type == "brms") {
    form_char[2] <- paste0(gsub("[|]", "| resp_weights(", form_char[2]), ")")
    if (any(!is.infinite(trunc))) {
      form_char[2] <- paste0(form_char[2], " + trunc(lb = ", trunc[1], ", ub = ", trunc[2], ")")
    }
    if (!grepl("[:]", model)) {
      model <- paste0(family, ": ", model)
    }
  } else {
    #* for other backends save weights variable
    lhs <- trimws(strsplit(form_char[2], "[|]")[[1]])
    weights <- lhs[2]
    form_char[2] <- lhs[1]
  }
  parsed_form <- as.formula(paste0(form_char[c(2, 1, 3)], collapse = ""))
  return(list(
    "formula" = parsed_form,
    "weights" = weights,
    "model" = model,
    "df" = df,
    "has_x_var" = has_x_var
  ))
}

#' `mvSS specified simple model helper functions`

#' @keywords internal
#' @noRd

.brms_mvss <- function(form = NULL, df = NULL, start = NULL, family = NULL, model = NULL, tau = NULL,
                       weights = NULL, pcvrform = NULL) {
  out <- list()
  #* `Make bayesian non-linear formula`
  bf1 <- as.formula(paste0(as.character(form)[2], "~ A"))
  bf2 <- as.formula(paste0("A ~ 0 + ", as.character(form)[3]))

  out[["formula"]] <- brms::bf(bf1, bf2, nl = TRUE)
  out[["prior"]] <- .makePriors(
    priors = start,
    pars = "A", df = df,
    group = "dummyGroup", # group from parse pcvr form should be dummy
    USEGROUP = FALSE,
    sigma = FALSE, family = family,
    formula = out[["formula"]]
  )
  out[["initfun"]] <- 0 # no fancy initialization here
  out[["df"]] <- df
  out[["family"]] <- family
  out[["pcvrForm"]] <- form
  out[["type"]] <- "brms"
  out[["model"]] <- trimws(gsub(".*:", "", model))
  return(out)
}

#' @keywords internal
#' @noRd

.nls_mvss <- function(form = NULL, df = NULL, start = NULL, family = NULL, model = NULL, tau = NULL,
                      weights = NULL, pcvrForm = NULL) {
  out <- list()
  out[["formula"]] <- form
  out[["start"]] <- NULL
  out[["df"]] <- df
  out[["pcvrForm"]] <- pcvrForm
  out[["type"]] <- "lm"
  out[["model"]] <- trimws(gsub(".*:", "", model))
  out[["weights"]] <- df[[weights]]
  return(out)
}

#' @keywords internal
#' @noRd

.nlrq_mvss <- function(form = NULL, df = NULL, start = NULL, family = NULL, model = NULL, tau = NULL,
                       weights = NULL, pcvrform = NULL) {
  out <- list()
  out[["formula"]] <- form
  out[["start"]] <- NULL
  out[["df"]] <- df
  out[["pcvrForm"]] <- pcvrform
  out[["type"]] <- "rq"
  out[["model"]] <- trimws(gsub(".*:", "", model))
  out[["taus"]] <- tau
  out[["weights"]] <- df[[weights]]
  return(out)
}

#' `Spectral Index helpers`

#' @keywords internal
#' @noRd
.none_mvss_hlp <- function() {
  truncation <- c(Inf, Inf) # unbounded
  family <- "student" # if not specified then leave as student T per default
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.ari_mvss_hlp <- function() {
  truncation <- c(Inf, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.ci_rededge_mvss_hlp <- function() {
  truncation <- c(-1, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.cri550_mvss_hlp <- function() {
  truncation <- c(Inf, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.cri700_mvss_hlp <- function() {
  truncation <- c(Inf, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.egi_mvss_hlp <- function() {
  truncation <- c(-1, 2)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.evi_mvss_hlp <- function() {
  truncation <- c(Inf, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.gdvi_mvss_hlp <- function() {
  truncation <- c(-2, 2)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.mari_mvss_hlp <- function() {
  truncation <- c(Inf, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.mcari_mvss_hlp <- function() {
  truncation <- c(Inf, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.mtci_mvss_hlp <- function() {
  truncation <- c(Inf, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.ndre_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.ndvi_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.pri_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.psnd_chlorophyll_a_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.psnd_chlorophyll_b_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.psnd_caroteniods_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.psri_mvss_hlp <- function() {
  truncation <- c(Inf, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.pssr_chlorophyll_a_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.pssr_chlorophyll_b_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.pssr_caroteniods_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.rgri_mvss_hlp <- function() {
  truncation <- c(0, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.rvsi_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.savi_mvss_hlp <- function() {
  truncation <- c(-1.2, 1.2)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.sipi_mvss_hlp <- function() {
  truncation <- c(Inf, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.sr_mvss_hlp <- function() {
  truncation <- c(0, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.vari_mvss_hlp <- function() {
  truncation <- c(Inf, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.vi_green_mvss_hlp <- function() {
  truncation <- c(-1, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.wi_mvss_hlp <- function() {
  truncation <- c(0, Inf)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.fvfm_mvss_hlp <- function() {
  truncation <- c(0, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}
#' @keywords internal
#' @noRd
.fqfm_mvss_hlp <- function() {
  truncation <- c(0, 1)
  family <- "skew_normal"
  return(list("trunc" = truncation, "family" = family))
}

#' Network analysis of a distance matrix
#'
#' @description Easy igraph use with pcv.emd output
#'
#'
#' @param emd A long dataframe as returned by pcv.emd.
#' Currently this function is only made to work with dataframe output,
#' not distance matrix output.
#' @param meta Metadata to be carried from pcv.emd output into the network,
#' defaults to NULL which will use all metadata.
#' Type conversion will be attempted for these columns.
#' @param dissim Logical, should the distCol be inverted to make a dissimilarity value?
#' @param distCol The name of the column containing distances/dissimilarities.
#' Defaults to "emd" for compatability with pcv.emd
#' @param filter This can be either a numeric (0.5) in which case it is taken as
#' a filter where only edges with values greater than or equal to that number are
#' kept or a character string ("0.5") in which case the strongest X percentage of edges are kept.
#' This defaults to 0.5 which does some filtering, although that should not be considered
#' the best behavior for every setting. If this is NULL then your network will be
#' almost always be a single blob, if set too high there will be very few nodes.
#' Note that this filtering happens after converting to dissimilarity if dissim=TRUE.
#' @param direction Direction of filtering, can be either "greater" or "lesser".
#' @import ggplot2
#' @import igraph
#' @importFrom utils type.convert
#' @importFrom stats quantile
#'
#' @keywords emd multi-value-trait network
#' @examples
#'
#' library(extraDistr)
#' dists <- list(
#'   rmixnorm = list(mean = c(70, 150), sd = c(15, 5), alpha = c(0.3, 0.7)),
#'   rnorm = list(mean = 90, sd = 3)
#' )
#' x <- mvSim(
#'   dists = dists, n_samples = 5, counts = 1000,
#'   min_bin = 1, max_bin = 180, wide = TRUE
#' )
#' emd_df <- pcv.emd(x,
#'   cols = "sim", reorder = c("group"), mat = FALSE,
#'   plot = FALSE, parallel = 1
#' )
#' net <- pcv.net(emd_df, meta = "group")
#' net2 <- pcv.net(emd_df, meta = "group", filter = "0.9", direction = "lesser")
#'
#' @return Returns a list containing three elements:
#' \code{nodes}: A dataframe of node data.
#' \code{edges}: A dataframe of edges between nodes.
#' \code{graph}: The network as an igraph object
#'
#' @export
#'

pcv.net <- function(emd = NULL, meta = NULL, dissim = TRUE, distCol = "emd", filter = 0.5,
                    direction = "greater") {
  if (is.data.frame(emd)) {
    #* convert to dissimilarity if metric is similarity
    if (dissim) {
      emd[[distCol]] <- 1 / emd[[distCol]]
      emd[[distCol]] <- ifelse(is.infinite(emd[[distCol]]) | is.na(emd[[distCol]]), 0, emd[[distCol]])
    }
    #* filter for edge strength
    if (!is.null(filter)) {
      if (is.character(filter)) {
        filter <- quantile(emd[[distCol]], probs = as.numeric(filter))
      }
      if (match.arg(direction, c("greater", "lesser")) == "greater") {
        emd <- emd[emd[[distCol]] > filter, ]
      } else {
        emd <- emd[emd[[distCol]] < filter, ]
      }
    }
    #* turn long data into a graph and extract nodes/edges
    g <- igraph::graph_from_data_frame(emd, directed = FALSE)
  } else {
    stop("emd must be a dataframe.")
  }
  if (is.null(meta)) {
    meta <- unique(sub("_i$|_j$", "", colnames(emd)[grepl("_i$|_j$", colnames(emd))]))
  }

  gg <- as.data.frame(igraph::layout_nicely(g))
  both <- igraph::as_data_frame(g, "both")
  gg$index <- both$vertices$name
  eg <- both$edges
  #* link metadata to nodes
  metaIndex <- lapply(meta, function(m) which(grepl(m, colnames(eg))))
  newCols <- (ncol(gg) + 1):(ncol(gg) + length(meta))
  gg[, newCols] <- lapply(metaIndex, function(m) {
    i <- m[[1]]
    j <- m[[2]]
    f <- eg[[i]][match(gg$index, eg$from)]
    to <- eg[[j]][match(gg$index, eg$to)]
    to[which(is.na(to))] <- f[which(is.na(to))]
    to
  }) # this can be NA if there is no 'from' edge connected to a node, so check 'to' edges as well.
  colnames(gg)[newCols] <- meta
  gg[, newCols] <- type.convert(gg[, newCols], as.is = TRUE)

  #* Calculate network metrics
  gg$betweenness <- igraph::betweenness(g)
  gg$degree <- igraph::degree(g)
  igraph::E(g)$weight <- eg[[distCol]] + 0.1
  gg$strength <- igraph::strength(g)
  gg$harmonic_centrality <- igraph::harmonic_centrality(g)
  gg$eigen_centrality <- igraph::eigen_centrality(g)[[1]]
  gg$authority_score <- igraph::authority_score(g)[[1]]
  gg$page_rank <- igraph::page_rank(g)[[1]]
  #* add coordinates for plotting edges
  eg$from.x <- gg$V1[match(eg$from, gg$index)]
  eg$from.y <- gg$V2[match(eg$from, gg$index)]
  eg$to.x <- gg$V1[match(eg$to, gg$index)]
  eg$to.y <- gg$V2[match(eg$to, gg$index)]
  return(list("nodes" = gg, "edges" = eg, "graph" = g))
}

#' Growth data simulating function
#'
#' @description growthSim can be used to help pick reasonable parameters for common
#'  growth models to use in prior distributions or to simulate data for example models/plots.
#'
#' @param model One of "logistic", "gompertz", "weibull", "frechet", "gumbel", "monomolecular",
#' "exponential", "linear", "power law", "logarithmic", "bragg",
#' "double logistic", or "double gompertz".
#' Alternatively this can be a pseudo formula to generate data from a segmented growth curve by
#' specifying "model1 + model2", see examples and \code{\link{growthSS}}.
#' Decay can be specified by including "decay" as part of the model such as "logistic decay" or
#' "linear + linear decay". Count data can be specified with the "count: " prefix,
#' similar to using "poisson: model" in \link{growthSS}.
#' While "gam" models are supported by \code{growthSS}
#' they are not simulated by this function.
#' @param n Number of individuals to simulate over time per each group in params
#' @param t Max time (assumed to start at 1) to simulate growth to as an integer.
#' @param params A list of numeric parameters. A, B, C notation is used in the order that parameters
#' appear in the formula (see examples). Number of groups is inferred from the length of these vectors
#' of parameters. In the case of the "double" models there are also A2, B2, and C2 terms.
#' Changepoints should be specified as "changePointX" or "fixedChangePointX" as in
#' \code{\link{growthSS}}.
#' @param D If decay is being simulated then this is the starting point for decay. This defaults to 0.
#'
#' @return Returns a dataframe of example growth data following the input parameters.
#'
#' @importFrom stats rnorm setNames
#'
#' @examples
#'
#' library(ggplot2)
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "Logistic")
#'
#' simdf <- growthSim("gompertz",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(0.2, 0.25))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "Gompertz")
#'
#' simdf <- growthSim("weibull",
#'   n = 20, t = 25,
#'   params = list("A" = c(100, 100), "B" = c(1, 0.75), "C" = c(2, 3))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "weibull")
#'
#' simdf <- growthSim("frechet",
#'   n = 20, t = 25,
#'   params = list("A" = c(100, 110), "B" = c(2, 1.5), "C" = c(5, 2))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "frechet")
#'
#' simdf <- growthSim("gumbel",
#'   n = 20, t = 25,
#'   list("A" = c(120, 140), "B" = c(6, 5), "C" = c(4, 3))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "gumbel")
#'
#' simdf <- growthSim("double logistic",
#'   n = 20, t = 70,
#'   params = list(
#'     "A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5),
#'     "A2" = c(400, 300), "B2" = c(35, 40), "C2" = c(3.25, 2.75)
#'   )
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "Double Logistic")
#'
#' simdf <- growthSim("double gompertz",
#'   n = 20, t = 100,
#'   params = list(
#'     "A" = c(180, 140), "B" = c(13, 11), "C" = c(0.2, 0.2),
#'     "A2" = c(400, 300), "B2" = c(50, 50), "C2" = c(0.1, 0.1)
#'   )
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "Double Gompertz")
#'
#' simdf <- growthSim("monomolecular",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(0.08, 0.1))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "Monomolecular")
#'
#' simdf <- growthSim("exponential",
#'   n = 20, t = 25,
#'   params = list("A" = c(15, 20), "B" = c(0.095, 0.095))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "Exponential")
#'
#' simdf <- growthSim("linear",
#'   n = 20, t = 25,
#'   params = list("A" = c(1.1, 0.95))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "Linear")
#'
#' simdf <- growthSim("logarithmic",
#'   n = 20, t = 25,
#'   params = list("A" = c(2, 1.7))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "Logarithmic")
#'
#' simdf <- growthSim("power law",
#'   n = 20, t = 25,
#'   params = list("A" = c(16, 11), "B" = c(0.75, 0.7))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "Power Law")
#'
#' simdf <- growthSim("bragg",
#'   n = 20, t = 100,
#'   list("A" = c(10, 15), "B" = c(0.01, 0.02), "C" = c(50, 60))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "bragg")
#'
#' # simulating models from segmented growth models
#'
#' simdf <- growthSim(
#'   model = "linear + linear", n = 20, t = 25,
#'   params = list("linear1A" = c(16, 11), "linear2A" = c(0.75, 0.7), "changePoint1" = c(11, 14))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "linear + linear")
#'
#' simdf <- growthSim(
#'   model = "linear + linear decay", n = 20, t = 25,
#'   params = list("linear1A" = c(16, 11), "linear2A" = c(3, 2), "changePoint1" = c(11, 14))
#' )
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "linear + linear decay")
#'
#' simdf <- growthSim(
#'   model = "linear + linear + logistic", n = 20, t = 50,
#'   params = list(
#'     "linear1A" = c(16, 11), "linear2A" = c(3, 4), # linear slopes, very intuitive
#'     "changePoint1" = c(11, 14), "changePoint2" = c(10, 12),
#'     # changepoint1 is standard, changepoint2 happens relative to changepoint 1
#'     "logistic3A" = c(200, 210), "logistic3B" = c(20, 25), "logistic3C" = c(3, 3)
#'   )
#' )
#' # similar to changepoint2, the asymptote and inflection point are relative to the starting
#' # point of the logistic growth component. This is different than the model output
#' # if you were to fit a curve to this model using `growthSS`.
#' ggplot(simdf, aes(time, y, group = interaction(group, id))) +
#'   geom_line(aes(color = group)) +
#'   labs(title = "linear + linear + logistic")
#'
#' @details
#'     The \code{params} argument requires some understanding of how each growth model is parameterized.
#'     Examples of each are below should help, as will the examples.
#'     \itemize{
#'     \item \bold{Logistic}: `A / (1 + exp( (B-x)/C) )`
#'     Where A is the asymptote, B is the inflection point, C is the growth rate.
#'     \item \bold{Gompertz}: `A * exp(-B * exp(-C*x))`
#'     Where A is the asymptote, B is the inflection point, C is the growth rate.
#'     \item \bold{Weibull}: `A * (1-exp(-(x/C)^B))`
#'     Where A is the asymptote, B is the weibull shape parameter, C is the weibull scale parameter.
#'     \item \bold{Frechet}: `A * exp(-((x-0)/C)^(-B))`
#'     Where A is the asymptote, B is the frechet shape parameter, C is the frechet scale parameter.
#'     Note that the location parameter (conventionally m) is 0 in these models for simplicity but is
#'     still included in the formula.
#'     \item \bold{Gumbel}: `A * exp(-exp(-(x-B)/C))`
#'     Where A is the asymptote, B is the inflection point (location), C is the growth rate (scale).
#'     \item \bold{Double Logistic}: `A / (1+exp((B-x)/C)) + ((A2-A) /(1+exp((B2-x)/C2)))`
#'     Where A is the asymptote, B is the inflection point, C is the growth rate,
#'     A2 is the second asymptote, B2 is the second inflection point, and C2 is the second
#'     growth rate.
#'     \item \bold{Double Gompertz}: `A * exp(-B * exp(-C*x)) + ((A2-A) * exp(-B2 * exp(-C2*(x-B))))`
#'     Where A is the asymptote, B is the inflection point, C is the growth rate,
#'     A2 is the second asymptote, B2 is the second inflection point, and C2 is the second
#'     growth rate.
#'     \item \bold{Monomolecular}: `A-A * exp(-B * x)`
#'     Where A is the asymptote and B is the growth rate.
#'     \item \bold{Exponential}: `A * exp(B * x)`
#'     Where A is the scale parameter and B is the growth rate.
#'     \item \bold{Linear}: `A * x`
#'     Where A is the growth rate.
#'     \item \bold{Logarithmic}: `A * log(x)`
#'     Where A is the growth rate.
#'     \item \bold{Power Law}: `A * x ^ (B)`
#'     Where A is the scale parameter and B is the growth rate.
#'     \item \bold{Bragg}: `A * exp(-B * (x - C) ^ 2)`
#'     This models minima and maxima as a dose-response curve where A is the max response,
#'     B is the "precision" or slope at inflection, and C is the x position of the max response.
#'     \item \bold{Lorentz}: `A / (1 + B * (x - C) ^ 2)`
#'     This models minima and maxima as a dose-response curve where A is the max response,
#'     B is the "precision" or slope at inflection, and C is the x position of the max response.
#'     Generally Bragg is preferred to Lorentz for dose-response curves.
#'     \item \bold{Beta}: `A * (((x - D) / (C - D)) * ((E - x) / (E - C)) ^ ((E - C) / (C - D))) ^ B`
#'     This models minima and maxima as a dose-response curve where A is the Maximum Value,
#'     B is a shape/concavity exponent similar to the sum of alpha and beta in a Beta distribution,
#'     C is the position of maximum value, D is the minimum position where distribution > 0,
#'     E is the maximum position where distribution > 0.
#'     This is a difficult model to fit but can model non-symmetric dose-response relationships which
#'     may sometimes be worth the extra effort.
#'     }
#'     Note that for these distributions parameters generally do not exist in a vacuum.
#'     Changing one will make the others look different in the resulting data.
#'     The examples are a good place to start if you are unsure what parameters to use.
#'
#' @export
#'
#'

growthSim <- function(
    model = c(
      "logistic", "gompertz", "double logistic", "double gompertz",
      "monomolecular", "exponential", "linear", "power law", "frechet",
      "weibull", "gumbel", "logarithmic", "bragg", "lorentz", "beta"
    ),
    n = 20, t = 25, params = list(), D = 0) {
  if (grepl("count:", model)) {
    COUNT <- TRUE
    model <- trimws(gsub("count:", "", model))
  } else {
    COUNT <- FALSE
  }
  if (is.null(names(params))) {
    names(params) <- c(LETTERS[seq_along(params)])
  }
  if (any(names(params) %in% letters)) {
    names(params) <- c(LETTERS[which(letters %in% substr(names(params), 1, 1))])
  }
  params <- as.list(params)
  noise <- lapply(params, function(i) mean(i) / 10)
  names(noise) <- names(params)
  if (any(grepl("fixedChangePoint", names(noise), ignore.case = TRUE))) {
    noise[grepl("fixedChangePoint", names(noise))] <- 0
    nms <- names(noise)
    nms <- sub("fixedC", "c", nms)
    names(noise) <- nms
    nms <- names(params)
    nms <- sub("fixedC", "c", nms)
    names(params) <- nms
  }

  #* check that params are all the same length, if not then rep until they are
  if (!all(unlist(lapply(params, length)) == max(unlist(lapply(params, length))))) {
    message("params are not uniform length, values are being recycled to fit max length")
    diffLengths <- which(!unlist(lapply(params, length)) == max(unlist(lapply(params, length))))
    params[diffLengths] <- lapply(
      diffLengths,
      function(i) {
        rep(params[[i]], length.out = max(unlist(lapply(params, length))))
      }
    )
  }
  #* decide which internal funciton to use
  if (!grepl("\\+", model)) {
    out <- .singleGrowthSim(model, n, t, params, noise, D)
  } else {
    out <- .multiGrowthSim(model, n, t, params, noise, D)
  }
  if (COUNT) {
    out <- do.call(rbind, lapply(split(out, interaction(out$group, out$id)), function(sub) {
      sub$y <- round(cummax(sub$y))
      sub
    }))
    rownames(out) <- NULL
  }
  return(out)
}

#' Internal helper function to simulate growth from a series of growth models
#' @keywords internal
#' @noRd

.multiGrowthSim <- function(model, n = 20, t = 25, params = list(), noise = NULL, D = 0) {
  component_models <- trimws(strsplit(model, "\\+")[[1]])

  firstModel <- component_models[1]
  firstModel <- trimws(firstModel)
  firstModelFindParams <- trimws(gsub("decay", "", firstModel))
  firstParams <- params[grepl(paste0(firstModelFindParams, "1"), names(params))]
  firstChangepoints <- params[["changePoint1"]]
  firstNoise <- noise[grepl(paste0(firstModelFindParams, "1|changePoint1"), names(noise))]
  names(firstNoise) <- sub(paste0(firstModelFindParams, "1|Point."), "", names(firstNoise))

  if (is.null(firstChangepoints)) {
    stop("Simulating segmented data requires 'changePointX' parameters as described in growthSS.")
  }

  df1 <- do.call(rbind, lapply(1:n, function(i) {
    firstChangepointsRand <- lapply(firstChangepoints, function(fc) {
      round(rnorm(1, fc, firstNoise$change))
    })

    n_df <- do.call(rbind, lapply(seq_along(firstChangepointsRand), function(g) {
      .singleGrowthSim(firstModel,
        n = 1, t = firstChangepointsRand[[g]],
        params = stats::setNames(
          lapply(firstParams, function(l) l[[g]]),
          c(sub(paste0(firstModel, "1"), "", names(firstParams)))
        ),
        noise = firstNoise, D
      )
    }))
    n_df$group <- rep(letters[seq_along(firstChangepointsRand)],
      times = unlist(firstChangepointsRand)
    )
    n_df$id <- paste0("id_", i)
    n_df
  }))
  dataList <- list(df1)

  for (u in 2:length(component_models)) {
    iterModel <- component_models[u]
    iterModel <- trimws(iterModel)
    iterModelFindParams <- trimws(gsub("decay", "", iterModel))
    iterParams <- params[grepl(paste0(iterModelFindParams, u), names(params))]

    nextChangepoints <- params[[paste0("changePoint", u)]]
    iterNoise <- noise[grepl(paste0(iterModelFindParams, u, "|changePoint", u), names(noise))]
    names(iterNoise) <- sub(paste0(iterModelFindParams, u, "|Point."), "", names(iterNoise))

    iter_data <- do.call(rbind, lapply(1:n, function(i) {
      if (is.null(nextChangepoints) | u == length(component_models)) {
        iterChangepointsRand <- rep(t, length(iterParams[[1]]))
      } else {
        iterChangepointsRand <- lapply(nextChangepoints, function(fc) {
          round(rnorm(1, fc, iterNoise$change))
        })
      }
      n_df <- do.call(rbind, lapply(seq_along(iterChangepointsRand), function(g) {
        if (u == length(component_models)) {
          gt <- t - max(df1[df1$id == paste0("id_", i), "time"])
        } else {
          gt <- iterChangepointsRand[[g]]
        }

        inner_df <- .singleGrowthSim(iterModel,
          n = 1, t = gt,
          params = stats::setNames(
            lapply(iterParams, function(l) l[[g]]),
            c(sub(paste0(iterModelFindParams, u), "", names(iterParams)))
          ),
          noise = iterNoise, D
        )
        inner_df$group <- letters[g]
        inner_df
      }))
      n_df$id <- paste0("id_", i)
      n_df
    }))

    prev_data <- dataList[[(u - 1)]]

    new_data <- do.call(rbind, lapply(unique(paste0(iter_data$id, iter_data$group)), function(int) {
      prev_data_sub <- prev_data[paste0(prev_data$id, prev_data$group) == int, ]
      iter_data_sub <- iter_data[paste0(iter_data$id, iter_data$group) == int, ]
      y_end <- prev_data_sub[prev_data_sub$time == max(prev_data_sub$time), "y"]
      iter_data_sub$time <- iter_data_sub$time + max(prev_data_sub$time)
      iter_data_sub$y <- iter_data_sub$y - iter_data_sub$y[1]
      iter_data_sub$y <- y_end + iter_data_sub$y
      iter_data_sub
    }))
    dataList[[(u)]] <- new_data
  }
  out <- do.call(rbind, dataList)
  out <- out[out$time < t, ]
  return(out)
}




#' Internal helper function to simulate growth from a single growth model
#' @keywords internal
#' @noRd

.singleGrowthSim <- function(model, n = 20, t = 25, params = list(), noise = NULL, D) {
  models <- c(
    "logistic", "gompertz", "double logistic", "double gompertz",
    "monomolecular", "exponential", "linear", "power law", "frechet", "weibull", "gumbel",
    "logarithmic", "bragg", "lorentz", "beta"
  )

  if (grepl("decay", model)) {
    decay <- TRUE
    model <- trimws(gsub("decay", "", model))
  } else {
    decay <- FALSE
  }

  matched_model <- match.arg(model, models)
  gsi <- match.fun(paste0("gsi_", gsub(" ", "", matched_model)))

  if (decay) {
    gsid <- function(D = 0, ...) {
      D - gsi(...)
    }
  } else {
    gsid <- function(D = 0, ...) {
      0 + gsi(...)
    }
  }

  out <- do.call(rbind, lapply(seq_along(params[[1]]), function(i) {
    pars <- lapply(params, function(p) p[i])
    as.data.frame(rbind(do.call(rbind, lapply(1:n, function(e) {
      data.frame(
        "id" = paste0("id_", e), "group" = letters[i], "time" = 1:t,
        "y" = gsid(D = D, 1:t, pars, noise), stringsAsFactors = FALSE
      )
    }))))
  }))

  return(out)
}


#* ************************************************************
#* ***** `gsi functions to simulate individual plants` *****
#* ************************************************************

gsi_logistic <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  c_r <- pars[["C"]] + rnorm(1, mean = 0, sd = noise[["C"]])
  return(a_r / (1 + exp((b_r - x) / c_r)))
}
gsi_gompertz <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  c_r <- pars[["C"]] + rnorm(1, mean = 0, sd = noise[["C"]])
  return(a_r * exp(-b_r * exp(-c_r * x)))
}
gsi_doublelogistic <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  c_r <- pars[["C"]] + rnorm(1, mean = 0, sd = noise[["C"]])
  a2_r <- pars[["A2"]] + rnorm(1, mean = 0, sd = noise[["A2"]])
  b2_r <- pars[["B2"]] + rnorm(1, mean = 0, sd = noise[["B2"]])
  c2_r <- pars[["C2"]] + rnorm(1, mean = 0, sd = noise[["C2"]])
  return(a_r / (1 + exp((b_r - x) / c_r)) + ((a2_r - a_r) / (1 + exp((b2_r - x) / c2_r))))
}
gsi_doublegompertz <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  c_r <- pars[["C"]] + rnorm(1, mean = 0, sd = noise[["C"]])
  a2_r <- pars[["A2"]] + rnorm(1, mean = 0, sd = noise[["A2"]])
  b2_r <- pars[["B2"]] + rnorm(1, mean = 0, sd = noise[["B2"]])
  c2_r <- pars[["C2"]] + rnorm(1, mean = 0, sd = noise[["C2"]])
  return((a_r * exp(-b_r * exp(-c_r * x))) + ((a2_r - a_r) * exp(-b2_r * exp(-c2_r * (x - b_r)))))
}
gsi_monomolecular <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  return(a_r - a_r * exp(-b_r * x))
}
gsi_exponential <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  return(a_r * exp(b_r * x))
}
gsi_linear <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  return(a_r * x)
}
gsi_powerlaw <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  return(a_r * x^(b_r))
}
gsi_logarithmic <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  return(a_r * log(x))
}
gsi_frechet <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- max(c(0, pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])))
  c_r <- max(c(0, pars[["C"]] + rnorm(1, mean = 0, sd = noise[["C"]])))
  # holding location to 0, b is shape parameter, c is scale (growth rate)
  return(a_r * exp(-((x - 0) / c_r)^(-b_r)))
}
gsi_gumbel <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  c_r <- pars[["C"]] + rnorm(1, mean = 0, sd = noise[["C"]])
  # b is location, c is scale (rate)
  return(a_r * exp(-exp(-(x - b_r) / c_r)))
}
gsi_weibull <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  c_r <- pars[["C"]] + rnorm(1, mean = 0, sd = noise[["C"]])
  # c is scale, b is shape
  return(a_r * (1 - exp(-(x / c_r)^b_r)))
}
gsi_bragg <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  c_r <- pars[["C"]] + rnorm(1, mean = 0, sd = noise[["C"]])
  # a is max response, b is precision, c is x position of max response
  return(a_r * exp(-b_r * (x - c_r)^2))
}
gsi_lorentz <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  c_r <- pars[["C"]] + rnorm(1, mean = 0, sd = noise[["C"]])
  # a is max response, b is precision, c is x position of max response
  return(a_r / (1 + b_r * (x - c_r)^2))
}
gsi_beta <- function(x, pars, noise) {
  a_r <- pars[["A"]] + rnorm(1, mean = 0, sd = noise[["A"]])
  b_r <- pars[["B"]] + rnorm(1, mean = 0, sd = noise[["B"]])
  c_r <- pars[["C"]] + rnorm(1, mean = 0, sd = noise[["C"]])
  d_r <- pars[["D"]] + rnorm(1, mean = 0, sd = noise[["D"]])
  e_r <- pars[["E"]] + rnorm(1, mean = 0, sd = noise[["E"]])
  y <- a_r * (((x - d_r) / (c_r - d_r)) * ((e_r - x) / (e_r - c_r))^((e_r - c_r) / (c_r - d_r)))^b_r
  return(y)
}

#' @description
#' Internal function for calculating \mu and \kappa of a distribution represented by multi value
#' traits.
#' @param s1 A data.frame or matrix of multi value traits. The column names should include a number
#' between 0.0001 and 0.9999 representing the "bin".
#' @examples
#' mv_gauss <- mvSim(
#'   dists = list(
#'     rnorm = list(mean = 50, sd = 10)
#'   ),
#'   n_samples = 30
#' )
#' .conj_vonmises_mv(
#'   s1 = mv_gauss[, -1], priors = list(mu = 30, kappa = 1, boundary = c(0, 180)),
#'   cred.int.level = 0.95,
#'   plot = TRUE
#' )
#' @keywords internal
#' @noRd

.conj_vonmises_mv <- function(s1 = NULL, priors = NULL,
                              plot = FALSE, support = NULL, cred.int.level = NULL,
                              calculatingSupport = FALSE) {
  #* `Turn off support for consistent rescaling between boundaries and to avoid default length of 10000`
  support <- NULL
  #* `Reorder columns if they are not in the numeric order`
  histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
  bins_order <- sort(histColsBin, index.return = TRUE)$ix
  s1 <- s1[, bins_order]
  #* `Turn s1 matrix into a vector`
  X1 <- rep(histColsBin[bins_order], as.numeric(round(colSums(s1))))
  #* `make default prior if none provided`
  default_prior <- list(
    mu = 0, kappa = 0.5,
    boundary = c(-pi, pi),
    known_kappa = 1, n = 1
  )
  if (is.null(priors)) {
    priors <- default_prior
  }
  #* `if any elements are missing from prior then use defaults`
  priors <- stats::setNames(lapply(names(default_prior), function(nm) {
    if (nm %in% names(priors)) {
      return(priors[[nm]])
    } else {
      return(default_prior[[nm]])
    }
  }), names(default_prior))
  #* `rescale data to [-pi, pi] according to boundary`
  X1 <- .boundary.to.radians(x = X1, boundary = priors$boundary)
  #* `rescale prior on mu to [-pi, pi] according to boundary`
  mu_radians <- .boundary.to.radians(x = priors$mu, boundary = priors$boundary)
  #* `Raise error if the boundary is wrong and data is not on [-pi, pi]`
  if (any(abs(X1) > pi)) {
    stop(paste0(
      "Values must be on [-pi, pi] after rescaling. ",
      "Does the boundary element in your prior include all your data?"
    ))
  }
  #* `Define dense Support`
  if (is.null(support)) {
    if (calculatingSupport) {
      return(priors$boundary) #* this would be [-pi, pi] if using radians, but plotting will be on
      #* the original scale so we can just return the boundary and use [-pi, pi] as support here
    }
    support_boundary <- seq(min(priors$boundary), max(priors$boundary), by = 0.0005)
    support <- seq(-pi, pi, length.out = length(support_boundary))
  }
  out <- list()
  #* `Get weighted mean of data and prior for half tangent adjustment`
  cm <- .circular.mean(c(X1, mu_radians), w = c(rep(nrow(s1) / length(X1), length(X1)), priors$n))
  unitCircleAdj <- ifelse(abs(cm) <= pi / 2, 0, pi)
  unitCircleAdj <- ifelse(cm > 0, 1, -1) * unitCircleAdj
  #* `Update prior parameters`
  a <- priors$kappa
  b <- mu_radians
  kappa_known <- priors$known_kappa
  kappa_prime <- kappa_known * .unbiased.kappa(X1)
  #* workaround for samples where kappa becomes negative if using the updating from the compendium
  #* where kappa prime is kappa_known x (A x sin B) + sum of sin data
  #*
  #* compendium and other sources I have read so far do not address this situation.
  #* seems like this would come up a lot, only difference I have seen is using [-pi, pi] vs
  #* the compendiums [0, 2pi], but I don't think that should make a difference.

  mu_prime_atan_scale <- atan(((a * sin(b)) + sum(sin(X1))) / ((a * cos(b)) + sum(cos(X1))))
  mu_prime <- unitCircleAdj + mu_prime_atan_scale
  #* `calculate density over support`
  dens1 <- brms::dvon_mises(support, mu_prime, kappa_prime)
  pdf1 <- dens1 / sum(dens1)
  #* `calculate highest density interval`
  #* note there is no qvon_mises function, so I am using bayestestR::hdi on
  #* posterior draws and rescaled posterior draws
  draws <- brms::rvon_mises(10000, mu_prime, kappa_prime)
  hdi_v1 <- as.numeric(bayestestR::hdi(draws, ci = cred.int.level))[2:3]
  draws2 <- draws
  draws2[draws2 < 0] <- draws2[draws2 < 0] + 2 * pi
  hdi_v2 <- as.numeric(bayestestR::hdi(draws2, ci = cred.int.level))[2:3]
  hdis <- list(hdi_v1, hdi_v2)
  hdi <- hdis[[which.min(c(diff(hdi_v1), diff(hdi_v2)))]]
  hdi[hdi > pi] <- hdi[hdi > pi] - (2 * pi) # if the second hdi was narrower then fix the part beyond pi
  #* `store highest density estimate`
  hde <- mu_prime
  #* `Rescale HDI, HDE, and draws, from radians to boundary units`
  hdi_boundary <- .radians.to.boundary(hdi, target = priors$boundary)
  hde_boundary <- .radians.to.boundary(hde, target = priors$boundary)
  draws_boundary <- .radians.to.boundary(draws, target = priors$boundary)
  #* `save summary and parameters`
  out$summary <- data.frame(
    HDE_1 = hde_boundary,
    HDI_1_low = hdi_boundary[1],
    HDI_1_high = hdi_boundary[2]
  )
  out$posterior$mu <- hde_boundary # rescaled mu_prime
  out$posterior$kappa <- kappa_prime
  out$posterior$known_kappa <- priors$known_kappa
  out$posterior$n <- priors$n + nrow(s1)
  out$posterior$boundary <- priors$boundary
  #* `Store Posterior Draws`
  out$posteriorDraws <- draws_boundary
  out$pdf <- pdf1
  #* `keep data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support_boundary, "prob" = pdf1,
      "sample" = rep("Sample 1", length(support_boundary))
    )
  }
  return(out)
}


#' @description
#' Internal function for calculating \mu and \kappa of a distribution represented by single value
#' traits.
#' @param s1 A vector of numerics drawn from a beta distribution.
#' @examples
#' .conj_vonmises_sv(
#'   s1 = brms::rvon_mises(100, 2, 2), priors = list(mu = 0.5, kappa = 0.5),
#'   cred.int.level = 0.95,
#'   plot = FALSE
#' )
#' .conj_vonmises_sv(
#'   s1 = rnorm(20, 90, 20),
#'   priors = list(mu = 75, kappa = 0.5, boundary = c(0, 180), known_kappa = 2),
#'   cred.int.level = 0.95,
#'   plot = TRUE
#' )
#' @keywords internal
#' @noRd

.conj_vonmises_sv <- function(s1 = NULL, priors = NULL,
                              plot = FALSE, support = NULL, cred.int.level = NULL,
                              calculatingSupport = FALSE) {
  #* `to avoid default support length of 10000 which may not span boundary well`
  support <- NULL
  #* `make default prior if none provided`
  default_prior <- list(
    mu = 0, kappa = 0.5,
    boundary = c(-pi, pi),
    known_kappa = 1, n = 1
  )
  if (is.null(priors)) {
    priors <- default_prior
  }
  #* `if any elements are missing from prior then use defaults`
  priors <- stats::setNames(lapply(names(default_prior), function(nm) {
    if (nm %in% names(priors)) {
      return(priors[[nm]])
    } else {
      return(default_prior[[nm]])
    }
  }), names(default_prior))
  #* `rescale data to [-pi, pi] according to boundary`
  s1 <- .boundary.to.radians(x = s1, boundary = priors$boundary)
  #* `rescale prior on mu to [-pi, pi] according to boundary`
  mu_radians <- .boundary.to.radians(x = priors$mu, boundary = priors$boundary)
  #* `Raise error if the boundary is wrong and data is not on [-pi, pi]`
  if (any(abs(s1) > pi)) {
    stop(paste0(
      "Values must be on [-pi, pi] after rescaling. ",
      "Does the boundary element in your prior include all your data?"
    ))
  }
  #* `Define dense Support`
  if (is.null(support)) {
    if (calculatingSupport) {
      return(priors$boundary) #* this would be [-pi, pi] if using radians, but plotting will be on
      #* the original scale so we can just return the boundary and use [-pi, pi] as support here
    }
    support_boundary <- seq(min(priors$boundary), max(priors$boundary), by = 0.0005)
    support <- seq(-pi, pi, length.out = length(support_boundary))
  }
  out <- list()
  #* `Get weighted mean of data and prior for half tangent adjustment`
  cm <- .circular.mean(c(s1, mu_radians), w = c(rep(1, length(s1)), priors$n))
  unitCircleAdj <- ifelse(abs(cm) <= pi / 2, 0, pi)
  unitCircleAdj <- ifelse(cm > 0, 1, -1) * unitCircleAdj
  #* `Update prior parameters`
  a <- priors$kappa
  b <- mu_radians
  kappa_known <- priors$known_kappa
  kappa_known <- priors$known_kappa
  kappa_prime <- kappa_known * .unbiased.kappa(s1)
  #* workaround for samples where kappa becomes negative if using the updating from the compendium
  #* where kappa prime is kappa_known x (A x sin B) + sum of sin data
  #* compendium and other sources I have read so far do not address this problem.
  #* seems like this would come up a lot, only difference I have seen is using [-pi, pi] vs
  #* the compendiums [0, 2pi], but I don't think that should make a difference.
  mu_prime_atan_scale <- atan(((a * sin(b)) + sum(sin(s1))) / ((a * cos(b)) + sum(cos(s1))))
  mu_prime <- unitCircleAdj + mu_prime_atan_scale
  #* `calculate density over support`
  dens1 <- brms::dvon_mises(support, mu_prime, kappa_prime)
  pdf1 <- dens1 / sum(dens1)
  #* `calculate highest density interval`
  #* note there is no qvon_mises function, so I am using bayestestR::hdi on
  #* posterior draws and rescaled posterior draws
  draws <- brms::rvon_mises(10000, mu_prime, kappa_prime)
  hdi_v1 <- as.numeric(bayestestR::hdi(draws, ci = cred.int.level))[2:3]
  draws2 <- draws
  draws2[draws2 < 0] <- draws2[draws2 < 0] + 2 * pi
  hdi_v2 <- as.numeric(bayestestR::hdi(draws2, ci = cred.int.level))[2:3]
  hdis <- list(hdi_v1, hdi_v2)
  hdi <- hdis[[which.min(c(diff(hdi_v1), diff(hdi_v2)))]]
  hdi[hdi > pi] <- hdi[hdi > pi] - (2 * pi) # if the second hdi was narrower then fix the part beyond pi
  #* `store highest density estimate`
  hde <- mu_prime
  #* `Rescale HDI, HDE, draws, and support from radians to boundary units`
  hdi_boundary <- .radians.to.boundary(hdi, target = priors$boundary)
  hde_boundary <- .radians.to.boundary(hde, target = priors$boundary)
  draws_boundary <- .radians.to.boundary(draws, target = priors$boundary)
  support_boundary <- .radians.to.boundary(support, target = priors$boundary)
  #* `save summary and parameters`
  out$summary <- data.frame(
    HDE_1 = hde_boundary,
    HDI_1_low = hdi_boundary[1],
    HDI_1_high = hdi_boundary[2]
  )
  out$posterior$mu <- hde_boundary # rescaled mu_prime
  out$posterior$kappa <- kappa_prime
  out$posterior$known_kappa <- priors$known_kappa
  out$posterior$n <- priors$n + length(s1)
  out$posterior$boundary <- priors$boundary
  #* `Store Posterior Draws`
  out$posteriorDraws <- draws_boundary
  out$pdf <- pdf1
  #* `keep data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support_boundary, "prob" = pdf1,
      "sample" = rep("Sample 1", length(support_boundary))
    )
  }
  return(out)
}

#' @description
#' Weighted Circular Mean function for use in von mises distribution conjugate function
#' @param x A vector of numerics drawn from a beta distribution.
#' @param w optional weights vector
#' @examples
#' \donttest{
#' .circular.mean(brms::rvon_mises(20, -3.1, 4))
#' }
#' @keywords internal
#' @noRd

.circular.mean <- function(x, w = NULL) {
  if (is.null(w)) {
    w <- rep(1, length(x))
  }
  sinr <- sum(sin(x) * w)
  cosr <- sum(cos(x) * w)
  circmean <- atan2(sinr, cosr)
  return(circmean)
}

#' @description
#' Function for rescaling any circular distribution to radians based on the edges.
#' @param x A vector of numerics from a circular process
#' @param boundary The edges of the circular process as a 2L numeric
#' @param target the target circular space, should not be changed from radians (-pi, pi).
#' @examples
#' \donttest{
#' x <- seq(-6, 6, length.out = 20)
#' .boundary.to.radians(x, c(6.3, 6.3))
#'
#' x <- seq(0, 100, length.out = 20)
#' .boundary.to.radians(x, c(0, 100))
#' }
#' @keywords internal
#' @noRd

.boundary.to.radians <- function(x, boundary, target = c(-pi, pi)) {
  x1 <- (target[2] - target[1]) / (boundary[2] - boundary[1]) * (x - boundary[2]) + target[2]
  return(x1)
}

#' @description
#' Convenience function for easier reading. Same as .boundary.to.radians() with different defaults.
#' @param x A vector of numerics from a von mises distribution
#' @param boundary The edges of the circular process,
#' generally these should not be changed from radians.
#' @param target the target circular space, should be from priors$boundary.
#' @examples
#' \donttest{
#' x <- brms::rvon_mises(20, 2, 3)
#' .radians.to.boundary(x, target = c(6.3, 6.3))
#'
#' x <- brms::rvon_mises(20, 3.1, 2)
#' .radians.to.boundary(x, target = c(0, 100))
#' }
#' @keywords internal
#' @noRd

.radians.to.boundary <- function(x, boundary = c(-pi, pi), target = c(-100, 100)) {
  x1 <- (target[2] - target[1]) / (boundary[2] - boundary[1]) * (x - boundary[2]) + target[2]
  return(x1)
}

#' @description
#' Calculate difference in draws from posterior of a von-mises distribution that has been
#' rescaled to exist on some circular space defined by the prior boundaries.
#' @param draws1 draws from a distribution
#' @param draws2 draws from another distribution
#' @param boundary a boundary vector describing the circular space's edges. Should be from priors.
#' @examples
#' \donttest{
#' draws1 <- brms::rvon_mises(10000, 3.1, 4)
#' draws2 <- brms::rvon_mises(10000, -3, 2)
#' x <- .conj_rope_circular_diff(draws1, draws2)
#' }
#' @keywords internal
#' @noRd

.conj_rope_circular_diff <- function(draws1, draws2, boundary = c(-pi, pi)) {
  draws1_radians <- .boundary.to.radians(draws1, boundary = boundary, target = c(-pi, pi))
  draws2_radians <- .boundary.to.radians(draws2, boundary = boundary, target = c(-pi, pi))
  span <- 2 * pi
  x <- draws1_radians + pi
  y <- draws2_radians + pi
  diff <- (x - y) %% span
  diff <- ifelse(diff <= (span / 2), diff, diff - span)
  diff <- .radians.to.boundary(diff, target = boundary) - mean(boundary)
  return(diff)
}

#' @description
#' Internal function for calculating \alpha and \beta of a beta distributed p (probability) parameter
#' in a beta-binomial conjugate distribution.
#'
#' @param s1 A named list of integer data containing number of successes and number of trials.
#' @examples
#' .conj_binomial_sv(
#'   s1 = list(successes = c(15, 14, 16, 11), trials = 20),
#'   priors = list(a = c(0.5, 0.5), b = c(0.5, 0.5)),
#'   plot = FALSE, cred.int.level = 0.95
#' )
#' @keywords internal
#' @noRd

.conj_binomial_sv <- function(s1 = NULL, priors = NULL,
                              plot = FALSE, support = NULL, cred.int.level = NULL,
                              calculatingSupport = FALSE) {
  #* `check stopping conditions`
  s1 <- .conj_binomial_formatter(s1)
  #* `separate data into counts and trials`
  s1_successes <- s1$successes
  s1_trials <- s1$trials
  #* `Replicate trials numbers if too short`
  if (length(s1_trials) < length(s1_successes)) {
    s1_trials <- rep(s1_trials, length(s1_successes))
  }

  #* `make default prior if none provided`
  #* `p parameter is beta distributed`
  if (is.null(priors)) {
    priors <- list(a = 0.5, b = 0.5)
  }
  #* `Define dense Support`
  #* `p parameter is beta distributed`
  if (is.null(support) && calculatingSupport) {
    return(c(0.0001, 0.9999))
  }
  out <- list()
  #* `Update priors with observed counts`
  a1_prime <- priors$a[1] + sum(s1_successes)
  b1_prime <- priors$b[1] + sum(s1_trials) - sum(s1_successes)

  #* `calculate density over support``
  dens1 <- dbeta(support, a1_prime, b1_prime)
  pdf1 <- dens1 / sum(dens1)

  #* `calculate highest density interval`
  hdi1 <- qbeta(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), a1_prime, b1_prime)

  #* `calculate highest density estimate``
  hde1 <- .betaHDE(a1_prime, b1_prime)
  #* `save summary and parameters`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior$a <- a1_prime
  out$posterior$b <- b1_prime
  #* `Make Posterior Draws`
  out$posteriorDraws <- rbeta(10000, a1_prime, b1_prime)
  out$pdf <- pdf1
  #* `keep data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support, "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' Error condition handling helper function
#' @param s1 The sample given to conjugate and conjugate_binomial_sv
#' @keywords internal
#' @noRd

.conj_binomial_formatter <- function(s1) {
  #* `Check data for stopping conditions`
  if (any(unlist(s1) < 0)) {
    stop(paste0(
      "Binomial method requires successes and trials in sample data",
      " as a list of two positive integer vectors. See examples."
    ))
  }
  if (length(s1) != 2) {
    stop(paste0(
      "Binomial method requires successes and trials in sample data",
      " as a list of two integer vectors. See examples."
    ))
  }
  if (any(is.null(names(s1)), names(s1) != c("successes", "trials"))) {
    message("Assuming sample data is in order 'successes', 'trials'.")
    names(s1) <- c("successes", "trials")
  }
  return(s1)
}

#' Multi Value Trait simulating function
#'
#' @description mvSim can be used to simulate data for example models/plots.
#'
#' @param n_samples Number of samples per distribution to generate. Defaults to 10, can be >1L.
#' @param counts Number of counts per histogram, defaults to 1000.
#' @param max_bin The number of bins to return. Note that this is also the max value that will be
#' accepted in the distribution functions, with higher numbers being shrunk to this value.
#' Defaults to 180.
#' @param min_bin The minumum bin number. This can be thought of as the minimum value that will
#' be accepted in the distribution functions, with lower numbers being raised to this value.
#' Note that bin arguments are both ignored in the case of "rbeta" and treated as 0,1.
#' @param dists A list of lists, with names corresponding to random deviate generating functions
#' and arguments to the function in the list values (see examples). Note that the n argument
#' does not need to be provided.
#' @param wide Boolean, should data be returned in wide format (the default)?
#' If FALSE then long data is returned.
#' @param binwidth How wide should bins be? Defaults to 1.
#' @keywords multi-value
#' @return Returns a dataframe of example multi-value trait data simulated from specified distributions.
#'
#' @importFrom graphics hist
#' @importFrom data.table melt as.data.table
#'
#' @examples
#'
#' library(extraDistr) # for rmixnorm
#' library(ggplot2)
#' n_samples = 10
#' counts = 1000
#' min_bin = 0
#' max_bin = 180
#' dists <- list(
#'   rmixnorm = list(mean = c(70, 150), sd = c(15, 5), alpha = c(0.3, 0.7)),
#'   rnorm = list(mean = 90, sd = 3)
#' )
#' x <- mvSim(dists = dists, wide = FALSE)
#' dim(x)
#' x2 <- mvSim(dists = dists)
#' dim(x2)
#'
#' ggplot(x, aes(
#'   x = as.numeric(sub("sim_", "", variable)),
#'   y = value, group = interaction(group, id), fill = group
#' )) +
#'   geom_col(position = "identity", alpha = 0.25) +
#'   pcv_theme() +
#'   labs(x = "bin")
#'
#' @export

mvSim <- function(dists = list(rnorm = list(mean = 100, sd = 15)),
                  n_samples = 10, counts = 1000, min_bin = 1, max_bin = 180, wide = TRUE,
                  binwidth = 1) {
  if (length(n_samples) == 1) {
    n_samples <- rep(n_samples, length(dists))
  }
  vecs <- .makeVecs(dists, counts, n_samples)
  out <- .simFreqs(vecs, max_bin, min_bin, binwidth)
  if (!wide) {
    out$id <- seq_len(nrow(out))
    out <- as.data.frame(data.table::melt(data.table::as.data.table(out), id.vars = c("group", "id")))
  }
  return(out)
}

#' internal vector making helper function
#' @keywords internal
#' @noRd

.makeVecs <- function(dists, counts, n_samples) {
  funs <- names(dists)
  out <- lapply(seq_along(funs), function(i) {
    f <- funs[i]
    fun <- match.fun(f)
    dists[[i]]$n <- counts
    lapply(1:n_samples[i], function(e) {
      do.call(fun, args = dists[[i]])
    })
  })
  names(out) <- names(dists)
  return(out)
}

#' internal histogram making helper function
#' @keywords internal
#' @noRd

.simFreqs <- function(vecs, max_bin, min_bin, binwidth) {
  do.call(rbind, lapply(seq_along(vecs), function(i) {
    vecName <- names(vecs)[i]
    vec <- vecs[[i]]
    do.call(rbind, lapply(vec, function(v) {
      if (vecName == "rbeta") {
        v[v > 1] <- 1
        v[v < 0] <- 0
        s1 <- hist(v, breaks = seq(0, 1, length.out = 100), plot = FALSE)$counts
        s1d <- as.data.frame(cbind(data.frame(vecName), matrix(s1, nrow = 1)))
        colnames(s1d) <- c("group", paste0("sim_", seq(0.01, 0.99, 0.01)))
      } else {
        v[v > max_bin] <- max_bin
        v[v < min_bin] <- min_bin
        s1 <- hist(v, breaks = seq(min_bin, (max_bin + binwidth), binwidth), plot = FALSE)$counts
        s1d <- as.data.frame(cbind(data.frame(vecName), matrix(s1, nrow = 1)))
        colnames(s1d) <- c("group", paste0("sim_", seq(min_bin, max_bin, binwidth)))
      }
      s1d
    }))
  }))
}

#' @description
#' Internal function for calculating the pareto distribution of the upper boundary of a uniform
#' distribution represented by single value traits.
#' @param s1 A vector of numerics drawn from a uniform distribution.
#' @examples
#'
#' out <- .conj_bivariate_lognormal_sv(
#'   s1 = rnorm(10, 50, 10), cred.int.level = 0.95,
#'   plot = FALSE
#' )
#' lapply(out, head)
#'
#' @keywords internal
#' @noRd

.conj_bivariate_gaussian_sv <- function(s1 = NULL, priors = NULL,
                                        plot = FALSE, support = NULL, cred.int.level = NULL,
                                        calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  #* conjugate prior needs alpha, beta, mu, prec (or var or sd)
  #* precision is Gamma(alpha, beta)
  #* mu is T_[2*alpha](mu, precision)
  if (is.null(priors)) {
    priors <- list(mu = 0, sd = 10, a = 1, b = 1)
  }
  #* `Extract prior components`
  alpha <- priors$a[1]
  beta <- priors$b[1]
  mu <- priors$mu[1]
  prec <- 1 / (priors$sd^2)
  #* `Calculate sufficient statistics`
  n <- length(s1)
  x_bar <- mean(s1)
  ss <- sum((s1 - x_bar)^2)
  #* `Update priors with sufficient statistics`
  alpha_prime <- alpha + (n / 2)
  beta_prime <- 1 / ((1 / beta) + (ss / 2) + ((prec * n * ((x_bar - mu)^2)) / (2 * (prec + n))))
  mu_prime <- ((prec * mu) + (n * x_bar)) / (prec + n)
  prec_prime <- prec + n
  df_prime <- 2 * alpha_prime
  prec_prime_t <- alpha_prime * prec_prime * beta_prime
  sigma_prime <- sqrt(1 / prec_prime_t)
  #* `Define bivariate support if it is missing`
  if (is.null(support)) {
    quantiles_mu <- extraDistr::qlst(c(0.0001, 0.9999), df_prime, mu_prime, sigma_prime)
    quantiles_prec <- stats::qgamma(c(0.0001, 0.9999), shape = alpha_prime, scale = beta_prime)
    support_mu <- seq(quantiles_mu[1], quantiles_mu[2], length.out = 10000)
    support_prec <- seq(quantiles_prec[1], quantiles_prec[2], length.out = 10000)
    if (calculatingSupport) {
      return(list("Mu" = quantiles_mu, "Prec" = quantiles_prec))
    }
  } else {
    support_mu <- support$Mu
    support_prec <- support$Prec
  }
  #* `Make Posterior Draws`
  out$posteriorDraws <- .conj_biv_rough_sampling(
    10000, alpha_prime, beta_prime,
    mu_prime, sigma_prime, df_prime
  )
  #* `posterior`
  dens_mu <- extraDistr::dlst(support_mu, df_prime, mu_prime, sigma_prime)
  dens_prec <- stats::dgamma(support_prec, shape = alpha_prime, scale = beta_prime)

  pdf_mu <- dens_mu / sum(dens_mu)
  pdf_prec <- dens_prec / sum(dens_prec)
  out$pdf <- list("Mu" = pdf_mu, "Prec" = pdf_prec)

  hde_mu <- mu_prime
  hde_prec <- .gammaHDE(shape = alpha_prime, scale = beta_prime)
  hdi_mu <- -1 * rev(extraDistr::qlst(
    c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    df_prime, mu_prime, sigma_prime
  ))
  hdi_prec <- -1 * rev(stats::qgamma(
    c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    shape = alpha_prime, scale = beta_prime
  ))

  #* `Store summary`
  out$summary <- data.frame(
    HDE_1 = c(hde_mu, hde_prec),
    HDI_1_low = c(hdi_mu[1], hdi_prec[1]),
    HDI_1_high = c(hdi_mu[2], hdi_prec[2]),
    param = c("Mu", "Prec")
  )
  out$posterior <- list(
    "mu" = mu_prime, "sd" = sigma_prime,
    "a" = alpha_prime, "b" = beta_prime
  )
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = c(support_mu, support_prec),
      "prob" = c(pdf_mu, pdf_prec),
      "param" = rep(c("Mu", "Prec"), each = length(support_mu)),
      "sample" = rep("Sample 1", 2 * length(support_mu))
    )
  }
  return(out)
}

.conj_biv_rough_sampling <- function(n, alpha, beta, mu, sigma, df) {
  #* I wanted this to be conditional inverse sampling
  #* but that doesn't work due to the t distribution
  #* this isn't used for hypothesis testing though, just visualization.
  x1 <- extraDistr::rlst(n, df, mu, sigma)
  x2 <- stats::rgamma(n, shape = alpha, scale = beta)
  return(cbind.data.frame("Mu" = x1, "Prec" = x2))
}

#' @description
#' Internal function for calculating the gamma distributed rate parameter of an exponential distribution
#' represented by single value traits.
#' @param s1 A vector of numerics drawn from a pareto distribution.
#' @examples
#' out <- .conj_exponential_sv(
#'   s1 = rexp(10, 3), cred.int.level = 0.95,
#'   plot = FALSE
#' )
#' lapply(out, head)
#' @keywords internal
#' @noRd
.conj_exponential_sv <- function(s1 = NULL, priors = NULL,
                                 plot = FALSE, support = NULL, cred.int.level = NULL,
                                 calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(a = 0.5, b = 0.5)
  }
  #* `Update gamma prior with sufficient statistics`
  n <- length(s1)
  S <- sum(s1)
  a_prime <- priors$a[1] + n
  b_prime <- priors$b[1] + S
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qgamma(c(0.0001, 0.9999), a_prime, b_prime)
    return(quantiles)
  }
  #* `Make Posterior Draws`
  out$posteriorDraws <- rgamma(10000, a_prime, b_prime)
  #* `posterior`
  dens1 <- dgamma(support, a_prime, b_prime)
  pdf1 <- dens1 / sum(dens1)
  out$pdf <- pdf1
  hde1 <- .gammaHDE(shape = a_prime, scale = 1 / b_prime)
  hdi1 <- qgamma(
    c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    a_prime, b_prime
  )
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior <- list(
    "a" = a_prime,
    "b" = b_prime
  )
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' Calculate pseudo water use efficiency from phenotype and watering data
#'
#' @description Rate based water use efficiency (WUE) is the change in biomass per unit of water
#' metabolized. Using image based phenotypes and watering data we can calculate pseudo-WUE (pwue) over
#' time. Here area_pixels is used as a proxy for biomass and transpiration is approximated using
#' watering data. The equation is then
#' \eqn{
#' \frac{P_{t} - P_{t-1}}{W_{t_{end-1}}-W_{t_{start}} }}{P_[t] - P_[t-1] / W_[t_(end-1)]-W_[t_start]
#' },
#' where P is the phenotype and W is the weight before watering.
#'
#' Absolute value based WUE is the amount of water used to sustain a plants biomass over a given period.
#' The equation is then
#' \eqn{\frac{P_{t}}{W_{t_{end-1}}-W_{t_{start}} }}{P_[t] / W_[t_(end-1)]-W_[t_start]}
#'
#' @param df Dataframe containing wide single-value phenotype data.
#'     This should already be aggregated to one row per plant per day (angles/rotations combined).
#' @param w Watering data as returned from bw.water.
#' @param pheno Phenotype column name, defaults to "area_pixels"
#' @param time Variable(s) that identify a plant on a given day.
#'     Defaults to \code{c("barcode", "DAS")}.
#' @param id Variable(s) that identify a plant over time. Defaults to \code{"barcode"}.
#' @param offset Optionally you can specify how long before imaging a watering should not be taken into
#' account. This defaults to 0, meaning that if a plant were watered directly before being imaged then
#' that water would be counted towards WUE between the current image and the prior one.
#' This argument is taken to be in seconds.
#' @param waterCol Column containing watering amounts in \code{w}. This defaults to "watering_amount".
#' @param method Which method to use, options are "rate" and "abs". The "rate" method considers WUE as
#' the change in a phenotype divided by the amount of water added. The "abs" method considers WUE as
#' the amount of water used by a plant given its absolute size. The former is for questions more
#' related to efficiency in using water to grow while the latter is more suited to questions about
#' how efficient a plant is at maintaining size given some amount of water.
#' @keywords WUE
#' @import data.table
#' @return A data frame containing the bellwether watering data joined
#'     to phenotype data with new columns for change in the phenotype,
#'     change in the pre-watering weight, and pseudo-water use efficiency (pWUE).
#' @examples
#' sim_water <- data.frame(
#'   "barcode" = "exampleBarcode1",
#'   "timestamp" = as.POSIXct(c(
#'     "2023-04-13 23:28:17 UTC",
#'     "2023-04-22 05:30:42 UTC",
#'     "2023-05-04 18:55:38 UTC"
#'   )),
#'   "DAS" = c(0.000000, 8.251675, 20.810660),
#'   "water_amount" = c(98, 12, -1)
#' )
#' sim_df <- data.frame(
#'   "barcode" = "exampleBarcode1",
#'   "timestamp" = as.POSIXct(c(
#'     "2023-04-13 23:28:17 UTC",
#'     "2023-04-22 05:30:42 UTC",
#'     "2023-05-04 18:55:38 UTC"
#'   )),
#'   "DAS" = c(0.000000, 8, 20),
#'   "area_pixels" = c(20, 1000, 1500)
#' )
#' pwue(
#'   df = sim_df, w = sim_water, pheno = "area_pixels",
#'   time = "timestamp", id = "barcode", offset = 0,
#'   waterCol = "water_amount", method = "rate"
#' )
#'
#' pwue(
#'   df = sim_df, w = sim_water, pheno = "area_pixels",
#'   time = c("timestamp", "timestamp"), id = "barcode", offset = 0,
#'   waterCol = "water_amount", method = "abs"
#' )
#'
#' @export

pwue <- function(df, w, pheno = "area_pixels", time = "timestamp", id = "barcode",
                 offset = 0, waterCol = "water_amount", method = "rate") {
  if (length(time) == 2) {
    time1 <- time[1]
    time2 <- time[2]
  } else {
    time1 <- time2 <- time
  }
  if (!time1 %in% colnames(df) || !time2 %in% colnames(w)) {
    stop(paste0(paste0(time, collapse = ", "), " must be in colnames of df and w"))
  }

  w <- data.table::setorderv(data.table::as.data.table(w), cols = c(id, time2))
  w <- w[w[[waterCol]] > 0, ]
  df <- data.table::setorderv(data.table::as.data.table(df), cols = c(id, time1))
  ids <- intersect(unique(w[, get(id)]), unique(df[, get(id)]))
  matched_method <- match.arg(method, choices = c("rate", "abs"))

  if (matched_method == "abs") {
    out <- .absWUE(ids, w, df, offset, time1, time2, pheno, id, waterCol)
  } else if (matched_method == "rate") {
    out <- .rateWUE(ids, w, df, offset, time1, time2, pheno, id, waterCol)
  }
  return(as.data.frame(out))
}

#' Function to calculate rate based WUE
#' @keywords internal
#' @noRd

.rateWUE <- function(ids, w, df, offset, time1, time2, pheno, id, waterCol) {
  out <- do.call(rbind, lapply(ids, function(iter_id) { # per id...
    w_i <- w[w[, get(id)] == iter_id, ]
    df_i <- df[df[, get(id)] == iter_id, ]
    #* reorder watering and pheno data
    w_i <- data.table::setorderv(w_i, cols = c(time2))
    df_i <- data.table::setorderv(df_i, cols = c(time1))
    #* get unique imaging times
    imaging_times <- unique(df_i[[time1]])
    #* set water from before first image to zero so that
    #* offset does not grab water from before imaging starts.
    w_i[[waterCol]] <- as.numeric(ifelse(w_i[[time2]] < imaging_times[1], 0, w_i[[waterCol]]))
    #* per imaging time
    wue_i <- do.call(rbind, lapply(seq_along(imaging_times), function(t_i) {
      start <- if (t_i == 1) {
        NA
      } else {
        imaging_times[(t_i - 1)] - offset
      }
      startNonOffset <- if (t_i == 1) {
        NA
      } else {
        imaging_times[(t_i - 1)]
      }
      end <- imaging_times[t_i] - offset
      endNonOffset <- imaging_times[t_i]
      if (!is.na(start)) {
        w_i_t <- w_i[w_i[[time2]] > start & w_i[[time2]] < end, ]
        total_water_i <- max(c(sum(w_i_t[[waterCol]]), 1))
        pheno_diff <- max(c(
          as.numeric(df_i[df_i[[time1]] == endNonOffset, get(pheno)] - df_i[
            df_i[[time1]] == startNonOffset, get(pheno)
          ]), 0
        ))
      } else {
        total_water_i <- NA
        pheno_diff <- NA
      }

      row <- data.frame(
        total_water = total_water_i,
        pheno_diff = pheno_diff,
        start = startNonOffset,
        end = endNonOffset,
        timeLengthSeconds = as.numeric(end) - as.numeric(start),
        offset = offset
      )
      row$pWUE <- row$pheno_diff / row$total_water
      return(row)
    }))
    iter_out <- cbind(df_i, wue_i)
    return(iter_out)
  }))
  return(out)
}

#' Function to calculate absolute value based WUE
#' @keywords internal
#' @noRd


.absWUE <- function(ids, w, df, offset, time1, time2, pheno, id, waterCol) {
  out <- do.call(rbind, lapply(ids, function(iter_id) { # per id...
    w_i <- w[w[[id]] == iter_id, ]
    df_i <- df[df[[id]] == iter_id, ]
    #* reorder watering and pheno data
    w_i <- data.table::setorderv(w_i, cols = c(time2))
    df_i <- data.table::setorderv(df_i, cols = c(time1))
    #* get unique imaging times
    imaging_times <- unique(df_i[[time1]])
    #* set water from before first image to zero so that offset
    #* does not grab water from before imaging starts.
    w_i[[waterCol]] <- ifelse(w_i[[time2]] < imaging_times[1], 0, w_i[[time2]])
    #* per imaging time
    wue_i <- do.call(rbind, lapply(seq_along(imaging_times), function(t_i) {
      start <- if (t_i == 1) {
        NA
      } else {
        imaging_times[(t_i - 1)] - offset
      }
      startNonOffset <- if (t_i == 1) {
        NA
      } else {
        imaging_times[(t_i - 1)]
      }
      end <- imaging_times[t_i] - offset
      endNonOffset <- imaging_times[t_i]

      if (!is.na(start)) {
        w_i_t <- w_i[w_i[[time2]] > start & w_i[[time2]] < end, ]
        total_water_i <- max(c(sum(w_i_t[[waterCol]]), 1))
        pheno_iter <- max(df_i[df_i[[time1]] == endNonOffset, get(pheno)], na.rm = TRUE)
      } else {
        total_water_i <- NA
        pheno_iter <- NA
      }

      row <- data.frame(
        total_water = total_water_i,
        pheno_iter = pheno_iter,
        start = startNonOffset,
        end = endNonOffset,
        timeLengthSeconds = as.numeric(end) - as.numeric(start),
        offset = offset
      )
      row$pWUE <- row$pheno_iter / row$total_water
      return(row)
    }))
    iter_out <- cbind(df_i, wue_i)
    return(iter_out)
  }))
  return(out)
}

#' Combine Draws From brms Models
#'
#' @description Helper function for binding draws from several \code{brms} models to make a data.frame
#' for use with \code{brms::hypothesis()}. This will also check that the draws are comparable using
#' basic model metrics.
#'
#' @param ... Some number of brmsfit objects and/or dataframes of draws
#' (should generally be the same type of model fit to different data)
#' @param message Logical, should messages about possible problems be printed? Default is TRUE.
#' This will warn if models may not have converged, if there are different numbers of draws in
#' the objects, or if models have different formulations.
#' @keywords brms
#' @importFrom methods is
#' @examples
#' # note that this example will fit several bayesian models and may run for several minutes.
#' \donttest{
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list(
#'     "A" = c(200, 160, 220, 200, 140, 300),
#'     "B" = c(13, 11, 10, 9, 16, 12),
#'     "C" = c(3, 3.5, 3.2, 2.8, 3.3, 2.5)
#'   )
#' )
#' ss_ab <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   sigma = "logistic", df = simdf[simdf$group %in% c("a", "b"), ],
#'   start = list(
#'     "A" = 130, "B" = 12, "C" = 3,
#'     "sigmaA" = 15, "sigmaB" = 10, "sigmaC" = 3
#'   ), type = "brms"
#' )
#'
#' ss_cd <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   sigma = "logistic", df = simdf[simdf$group %in% c("c", "d"), ],
#'   start = list(
#'     "A" = 130, "B" = 12, "C" = 3,
#'     "sigmaA" = 15, "sigmaB" = 10, "sigmaC" = 3
#'   ), type = "brms"
#' )
#'
#' ss_ef <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   sigma = "logistic", df = simdf[simdf$group %in% c("e", "f"), ],
#'   start = list(
#'     "A" = 130, "B" = 12, "C" = 3,
#'     "sigmaA" = 15, "sigmaB" = 10, "sigmaC" = 3
#'   ), type = "brms"
#' )
#' ss_ef2 <- growthSS(
#'   model = "gompertz", form = y ~ time | id / group,
#'   sigma = "logistic", df = simdf[simdf$group %in% c("e", "f"), ],
#'   start = list(
#'     "A" = 130, "B" = 12, "C" = 3,
#'     "sigmaA" = 15, "sigmaB" = 10, "sigmaC" = 3
#'   ), type = "brms"
#' )
#'
#'
#' fit_ab <- fitGrowth(ss_ab, chains = 1, cores = 1, iter = 1000)
#' fit_ab2 <- fitGrowth(ss_ab, chains = 1, cores = 1, iter = 1200)
#' fit_cd <- fitGrowth(ss_cd, chains = 1, cores = 1, iter = 1000)
#' fit_ef <- fitGrowth(ss_ef, chains = 1, cores = 1, iter = 1000)
#' fit_ef2 <- fitGrowth(ss_ef2, chains = 1, cores = 1, iter = 1000)
#'
#' x <- combineDraws(fit_ab, fit_cd, fit_ef)
#' draws_ef <- as.data.frame(fit_ef)
#' draws_ef <- draws_ef[, grepl("^b_", colnames(draws_ef))]
#' x2 <- combineDraws(fit_ab2, fit_cd, draws_ef)
#' x3 <- combineDraws(fit_ab, fit_cd, fit_ef2)
#' }
#'
#' @return Returns a dataframe of posterior draws.
#' @export




combineDraws <- function(..., message = TRUE) {
  objects <- list(...)
  if (!all(unlist(lapply(objects, function(m) {
    methods::is(m, "brmsfit") | methods::is(m, "data.frame")
  })))) {
    stop("Only brmsfit objects and data frames are accepted")
  }

  obj_names <- sapply(substitute(list(...)), deparse)[-1]
  models <- objects[unlist(lapply(objects, function(m) {
    methods::is(m, "brmsfit")
  }))]
  model_names <- obj_names[unlist(lapply(objects, function(m) {
    methods::is(m, "brmsfit")
  }))]
  supplied_draw_dfs <- objects[unlist(lapply(objects, function(m) {
    methods::is(m, "data.frame")
  }))]
  df_names <- obj_names[unlist(lapply(objects, function(m) {
    methods::is(m, "data.frame")
  }))]

  max_fit_draws <- max(unlist(lapply(models, function(m) {
    nrow(as.data.frame(m))
  })))
  max_nrow_supplied <- max(c(0, unlist(lapply(supplied_draw_dfs, nrow))))
  limit_size <- max(c(max_fit_draws, max_nrow_supplied))

  #* `check that formulae are the same`
  if (message) {
    formulae <- unlist(lapply(models, function(m) {
      x <- as.character(m$formula$formula)
      form <- paste0(x[2], x[1], x[3])
      return(form)
    }))
    names(formulae) <- model_names
    if (length(unique(formulae)) > 1) {
      message("Some of these models have different growth formulas, consider if this is what you want.")
      message(paste0(paste(names(formulae), formulae, sep = ": "), collapse = ", "))
    }
  }
  #* `get and bind draws from models`
  new_draws <- do.call(cbind, lapply(seq_along(models), function(i) {
    m <- models[[i]]
    mn <- model_names[[i]]
    d <- as.data.frame(m)
    draws <- d[, grepl("^b_", colnames(d))]
    colnames(draws) <- gsub("^b", mn, colnames(draws))

    if (message) {
      rhats <- brms::rhat(m)
      rhats <- rhats[grepl("^b_", names(rhats))]
      if (any(rhats > 1.05)) {
        message(paste0(
          mn, " has Rhat values >1.05 for some model parameters.",
          "See ?barg for possible improvements.\n"
        ))
      }
    }

    if (nrow(draws) < limit_size) {
      if (message) {
        message(paste0(
          mn, " has fewer than ", limit_size, " draws and will be padded with ",
          limit_size - nrow(draws), " NAs\n"
        ))
      }
      draws[(nrow(draws) + 1):limit_size, ] <- NA
      draws
    }
    draws
  }))
  #* `bind any other dataframes of draws`
  if (length(supplied_draw_dfs) > 0) {
    supplied_draw_dfs <- lapply(seq_along(supplied_draw_dfs), function(i) {
      df <- supplied_draw_dfs[[i]]
      dn <- df_names[[i]]
      if (nrow(df) < limit_size) {
        if (message) {
          message(paste0(
            dn, " has fewer than ", limit_size, " draws and will be padded with ",
            limit_size - nrow(df), " NAs\n"
          ))
        }
        df[(nrow(df) + 1):limit_size, ] <- NA
      }
      df
    })
    new_draws <- do.call(cbind, args = list(supplied_draw_dfs, new_draws))
  }
  new_draws
}

#' Bayesian testing using conjugate priors and method of moments for single or multi value traits.
#'
#' @description
#' Function to perform bayesian tests and ROPE comparisons using single or multi value traits with
#' several distributions.
#'
#' @param s1 A data.frame or matrix of multi value traits or a vector of single value traits.
#' If a multi value trait is used then column names should include a number representing the "bin".
#' Alternatively for distributions other than "binomial" (which requires list data
#' with "successes" and "trials" as numeric vectors in the list, see examples)
#' this can be a formula specifying \code{outcome ~ group} where group has exactly 2
#' levels. If using wide MV trait data then the formula should specify column positions ~ grouping
#' such as \code{1:180 ~ group}.
#' This sample is shown in red if plotted.
#' @param s2 An optional second sample, or if s1 is a formula then this should be a dataframe.
#' This sample is shown in blue if plotted.
#' @param method The distribution/method to use.
#' Currently "t", "gaussian", "beta", "binomial", "lognormal", "lognormal2", "poisson",
#' "negbin" (negative binomial), "uniform", "pareto", "gamma", "bernoulli", "exponential",
#' "vonmises", and "vonmises2" are supported.
#' The count (binomial, poisson and negative binomial), bernoulli, exponential,
#' and pareto distributions are only implemented for single value traits due to their updating
#' and/or the nature of the input data.
#' The "t" and "gaussian" methods both use a T distribution with "t" testing for a difference
#' of means and "gaussian" testing for a difference in the distributions (similar to a Z test).
#' Both Von Mises options are for use with circular data (for instance hue values when the circular
#' quality of the data is relevant). Note that non-circular distributions can be compared to each other.
#' This should only be done with caution. Make sure you understand the interpretation of any
#' comparison you are doing if you specify two methods (c("gaussian", "lognormal") as an arbitrary
#' example).
#' There are also 3 bivariate conjugate priors that are supported for use with single value data.
#' Those are "bivariate_uniform", "bivariate_gaussian" and "bivariate_lognormal".
#' @param priors Prior distributions described as a list of lists.
#' If this is a single list then it will be duplicated for the second sample,
#' which is generally a good idea if both
#' samples use the same distribution (method).
#' Elements in the inner lists should be named for the parameter they represent (see examples).
#' These names vary by method (see details).
#'  By default this is NULL and weak priors (generally jeffrey's priors) are used.
#'  The \code{posterior} part of output can also be recycled as a new prior if Bayesian
#'  updating is appropriate for your use.
#' @param plot Logical, should a ggplot be made and returned.
#' @param rope_range Optional vector specifying a region of practical equivalence.
#' This interval is considered practically equivalent to no effect.
#' Kruschke (2018) suggests c(-0.1, 0.1) as a broadly reasonable ROPE for standardized parameters.
#' That range could also be rescaled by a standard deviation/magnitude for
#' non-standardized parameters, but ultimately this should be informed by your
#' setting and scientific question.
#' See Kruschke (2018) for details on ROPE and other Bayesian methods to aide
#' decision-making \doi{10.1177/2515245918771304}
#' and \doi{10.1037/a0029146}.
#' @param rope_ci The credible interval probability to use for ROPE. Defaults to 0.89.
#' @param cred.int.level The credible interval probability to use
#' in computing HDI for samples, defaults to 0.89.
#' @param hypothesis Direction of a hypothesis if two samples are provided.
#'  Options are "unequal", "equal", "greater", and "lesser",
#'   read as "sample1 greater than sample2".
#' @param support Optional support vector to include all possible values the random variable
#'  (samples) might take. This defaults to NULL in which case each method will use default
#'  behavior to attempt to calculate a dense support, but it is a good idea to supply this
#'  with some suitable vector. For example, the Beta method uses \code{seq(0.0001, 0.9999, 0.0001)}
#'  for support.
#'
#' @import bayestestR
#' @import ggplot2
#' @import patchwork
#' @import extraDistr
#' @importFrom stats var median rnorm dnorm qbeta rbeta dbeta qbeta rlnorm
#' dlnorm qlnorm qt rgamma qgamma dgamma rpois runif
#'
#' @details
#'
#' Prior distributions default to be weakly informative and in some cases you may wish to change them.
#' \itemize{
#'    \item{\strong{"t" and "gaussian":} \code{priors = list( mu=c(0,0),n=c(1,1),s2=c(20,20) ) },
#'     where mu is the mean, n is the number of prior observations, and s2 is variance}
#'    \item{\strong{"beta", "bernoulli", and "binomial":}
#'    \code{priors = list( a=c(0.5, 0.5), b=c(0.5, 0.5) )},
#'     where a and b are shape parameters of the beta distribution. Note that for the binomial
#'     distribution this is used as the prior for success probability P,
#'     which is assumed to be beta distributed as in a beta-binomial distribution.}
#'    \item{\strong{"lognormal": } \code{priors = list(mu = 0, sd = 5) },
#'    where mu and sd describe the normal distribution of the mean parameter for lognormal data.
#'    Note that these values are on the log scale.}
#'    \item{\strong{"lognormal2": } \code{priors = list(a = 1, b = 1) },
#'    where a and b are the shape and scale parameters of the gamma distribution of lognormal data's
#'    precision parameter (using the alternative mu, precision paramterization).
#'    }
#'    \item{\strong{"gamma": } \code{priors = list(shape = 0.5, scale = 0.5, known_shape = 1)},
#'     where shape and scale are the respective parameters of the gamma distributed rate
#'     (inverse of scale) parameter of gamma distributed data.}
#'    \item{\strong{"poisson" and "exponential": } \code{priors = list(a=c(0.5,0.5),b=c(0.5,0.5))},
#'     where a and b are shape parameters of the gamma distribution.}
#'    \item{\strong{"negbin": } \code{priors = list(r=c(10,10), a=c(0.5,0.5),b=c(0.5,0.5))},
#'     where r is the r parameter of the negative binomial distribution
#'     (representing the number of successes required)
#'      and where a and b are shape parameters of the beta distribution.
#'      Note that the r value is not updated.
#'       The conjugate beta prior is only valid when r is fixed and known,
#'       which is a limitation for this method.}
#'     \item{\strong{"uniform": } \code{list(scale = 0.5, location = 0.5)}, where scale is the
#'     scale parameter of the pareto distributed upper boundary and location is the location parameter
#'     of the pareto distributed upper boundary. Note that different sources will use different
#'     terminology for these parameters. These names were chosen for consistency with the
#'     \code{extraDistr} implementation of the pareto distribution. On Wikipedia the parameters are
#'     called shape and scale, corresponding to extraDistr's scale and location respecitvely, which
#'     can be confusing. Note that the lower boundary of the uniform is assumed to be 0.
#'     }
#'     \item{\strong{"pareto": } \code{list(a = 1, b = 1, known_location = min(data))}, where
#'     a and b are the shape and scale parameters of the gamma distribution of the pareto distribution's
#'     scale parameter. In this case location is assumed to be constant and known, which is less of
#'     a limitation than knowing r for the negative binomial method since location will generally be
#'     right around/just under the minimum of the sample data. Note that the pareto method is only
#'     implemented currently for single value traits since one of the statistics needed to update
#'     the gamma distribution here is the product of the data and we do not currently have a method
#'     to calculate a similar sufficient statistic from multi value traits.
#'     }
#'     \item{\strong{"vonmises": } \code{list(mu = 0, kappa = 0.5, boundary = c(-pi, pi),
#'     known_kappa = 1, n = 1)}, where mu is the direction of the circular distribution (the mean),
#'     kappa is the precision of the mean, boundary is a vector including the two values that are the
#'     where the circular data "wraps" around the circle, known_kappa is the fixed value of precision
#'     for the total distribution, and n is the number of prior observations. This Von Mises option
#'     updates the conjugate prior for the mean direction, which is itself Von-Mises distributed. This
#'     in some ways is analogous to the T method, but assuming a fixed variance when the mean is
#'     updated. Note that due to how the rescaling works larger circular boundaries can be slow to
#'     plot.
#'     }
#'     \item{\strong{"vonmises2": } \code{priors = list(mu = 0, kappa = 0.5,
#'     boundary = c(-pi, pi), n = 1)}, where mu and kappa are mean direction and precision of the
#'     von mises distribution, boundary is a vector including the two values that are the
#'     where the circular data "wraps" around the circle, and n is the number of prior observations.
#'     This Von-Mises implementation does not assume constant variance and instead uses MLE to estimate
#'     kappa from the data and updates the kappa prior as a weighted average of the data and the prior.
#'     The mu parameter is then updated per Von-Mises conjugacy.
#'     }
#'     \item{\strong{"bivariate_uniform": }
#'     \code{list(location_l = 1, location_u = 2, scale = 1)}, where scale is the
#'     shared scale parameter of the pareto distributed upper and lower boundaries and location l and u
#'     are the location parameters for the Lower (l) and Upper (u) boundaries of the uniform
#'     distribution. Note this uses the same terminology for the pareto distribution's parameters
#'     as the "uniform" method.
#'     }
#'     \item{\strong{"bivariate_gaussian" and "bivariate_lognormal": }
#'     \code{list(mu = 0, sd = 10, a = 1, b = 1)}, where mu and sd
#'     are the mean and standard deviation of the Normal distribution of the data's mean and a and b
#'     are the shape and scale of the gamma distribution on precision. Note that internally this uses
#'     the Mu and Precision parameterization of the normal distribution and those are the parameters
#'     shown in the plot and tested, but priors use Mu and SD for the normal distribution of the mean.
#'     }
#' }
#'
#' See examples for plots of these prior distributions.
#'
#' @examples
#' mv_ln <- mvSim(
#'   dists = list(
#'     rlnorm = list(meanlog = log(130), sdlog = log(1.2)),
#'     rlnorm = list(meanlog = log(100), sdlog = log(1.3))
#'   ),
#'   n_samples = 30
#' )
#'
#' # lognormal mv
#' ln_mv_ex <- conjugate(
#'   s1 = mv_ln[1:30, -1], s2 = mv_ln[31:60, -1], method = "lognormal",
#'   priors = list(mu = 5, sd = 2),
#'   plot = FALSE, rope_range = c(-40, 40), rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal", support = NULL
#' )
#'
#' # lognormal sv
#' ln_sv_ex <- conjugate(
#'   s1 = rlnorm(100, log(130), log(1.3)), s2 = rlnorm(100, log(100), log(1.6)),
#'   method = "lognormal",
#'   priors = list(mu = 5, sd = 2),
#'   plot = FALSE, rope_range = NULL, rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal", support = NULL
#' )
#'
#' # Z test mv example
#'
#' mv_gauss <- mvSim(
#'   dists = list(
#'     rnorm = list(mean = 50, sd = 10),
#'     rnorm = list(mean = 60, sd = 12)
#'   ),
#'   n_samples = 30
#' )
#'
#' gauss_mv_ex <- conjugate(
#'   s1 = mv_gauss[1:30, -1], s2 = mv_gauss[31:60, -1], method = "gaussian",
#'   priors = list(mu = 30, n = 1, s2 = 100),
#'   plot = FALSE, rope_range = c(-25, 25), rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal", support = NULL
#' )
#'
#' # T test sv example
#'
#' gaussianMeans_sv_ex <- conjugate(
#'   s1 = rnorm(10, 50, 10), s2 = rnorm(10, 60, 12), method = "t",
#'   priors = list(mu = 30, n = 1, s2 = 100),
#'   plot = FALSE, rope_range = c(-5, 8), rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal", support = NULL
#' )
#'
#' # beta mv example
#'
#' set.seed(123)
#' mv_beta <- mvSim(
#'   dists = list(
#'     rbeta = list(shape1 = 5, shape2 = 8),
#'     rbeta = list(shape1 = 10, shape2 = 10)
#'   ),
#'   n_samples = c(30, 20)
#' )
#'
#' beta_mv_ex <- conjugate(
#'   s1 = mv_beta[1:30, -1], s2 = mv_beta[31:50, -1], method = "beta",
#'   priors = list(a = 0.5, b = 0.5),
#'   plot = FALSE, rope_range = c(-0.1, 0.1), rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal"
#' )
#'
#' # beta sv example
#'
#' beta_sv_ex <- conjugate(
#'   s1 = rbeta(20, 5, 5), s2 = rbeta(20, 8, 5), method = "beta",
#'   priors = list(a = 0.5, b = 0.5),
#'   plot = FALSE, rope_range = c(-0.1, 0.1), rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal"
#' )
#'
#' # binomial sv example
#' # note that specifying trials = 20 would also work
#' # and the number of trials will be recycled to the length of successes
#'
#' binomial_sv_ex <- conjugate(
#'   s1 = list(successes = c(15, 14, 16, 11), trials = c(20, 20, 20, 20)),
#'   s2 = list(successes = c(7, 8, 10, 5), trials = c(20, 20, 20, 20)), method = "binomial",
#'   priors = list(a = 0.5, b = 0.5),
#'   plot = FALSE, rope_range = c(-0.1, 0.1), rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal"
#' )
#'
#' # poisson sv example
#'
#' poisson_sv_ex <- conjugate(
#'   s1 = rpois(20, 10), s2 = rpois(20, 8), method = "poisson",
#'   priors = list(a = 0.5, b = 0.5),
#'   plot = FALSE, rope_range = c(-1, 1), rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal"
#' )
#'
#' # negative binomial sv example
#' # knowing r (required number of successes) is an important caveat for this method.
#' # in the current implementation we suggest using the poisson method for data such as leaf counts
#'
#' negbin_sv_ex <- conjugate(
#'   s1 = rnbinom(20, 10, 0.5), s2 = rnbinom(20, 10, 0.25), method = "negbin",
#'   priors = list(r = 10, a = 0.5, b = 0.5),
#'   plot = FALSE, rope_range = c(-1, 1), rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal"
#' )
#'
#' # von mises mv example
#'
#' mv_gauss <- mvSim(
#'   dists = list(
#'     rnorm = list(mean = 50, sd = 10),
#'     rnorm = list(mean = 60, sd = 12)
#'   ),
#'   n_samples = c(30, 40)
#' )
#' vm1_ex <- conjugate(
#'   s1 = mv_gauss[1:30, -1],
#'   s2 = mv_gauss[31:70, -1],
#'   method = "vonmises",
#'   priors = list(mu = 45, kappa = 1, boundary = c(0, 180), known_kappa = 1, n = 1),
#'   plot = FALSE, rope_range = c(-1, 1), rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal"
#' )
#'
#' # von mises 2 sv example
#' vm2_ex <- conjugate(
#'   s1 = brms::rvon_mises(10, 2, 2),
#'   s2 = brms::rvon_mises(15, 3, 3),
#'   method = "vonmises2",
#'   priors = list(mu = 0, kappa = 0.5, boundary = c(-pi, pi), n = 1),
#'   cred.int.level = 0.95,
#'   plot = FALSE
#' )
#'
#' @return
#'
#' A list with named elements:
#' \itemize{
#'    \item{\strong{summary}: A data frame containing HDI/HDE values for each sample and
#'    the ROPE as well as posterior probability of the hypothesis.}
#'    \item{\strong{posterior}: A list of updated parameters in the same format as the prior
#'     for the given method. If desired this does allow for Bayesian updating.}
#'    \item{\strong{plot_df}: A data frame of probabilities along the support for each sample.
#'     This is used for making the ggplot.}
#'    \item{\strong{rope_df}: A data frame of draws from the ROPE posterior.}
#'    \item{\strong{plot}: A ggplot showing the distribution of samples and optionally the
#'    distribution of differences/ROPE}
#' }
#'
#' @keywords bayesian conjugate priors ROPE
#' @export

conjugate <- function(s1 = NULL, s2 = NULL,
                      method = c(
                        "t", "gaussian", "beta", "binomial",
                        "lognormal", "lognormal2", "poisson", "negbin", "vonmises", "vonmises2",
                        "uniform", "pareto", "gamma", "bernoulli", "exponential", "bivariate_uniform",
                        "bivariate_gaussian", "bivariate_lognormal"
                      ),
                      priors = NULL, plot = FALSE, rope_range = NULL,
                      rope_ci = 0.89, cred.int.level = 0.89, hypothesis = "equal",
                      support = NULL) {
  #* `Handle formula option in s1`
  samples <- .formatSamples(s1, s2)
  s1 <- samples$s1
  s2 <- samples$s2
  #* `check length of method, replicate if there is a second sample`
  if (length(method) == 1 && !is.null(s2)) {
    method <- rep(method, 2)
  }
  if (!is.null(priors) && !methods::is(priors[[1]], "list")) {
    priors <- list(priors, priors)
  }
  samplesList <- list(s1)
  if (!is.null(s2)) {
    samplesList[[2]] <- s2
  }

  if (is.null(support)) {
    support <- .getSupport(samplesList, method, priors) # calculate shared support
  }

  sample_results <- lapply(seq_along(samplesList), function(i) {
    sample <- samplesList[[i]]
    prior <- priors[[i]]
    #* `Check sample class`
    if (is.matrix(sample) | is.data.frame(sample)) {
      vec_suffix <- "mv"
      sample <- .mvSampleFormatting(sample)
    } else if (is.vector(sample)) {
      vec_suffix <- "sv"
    }
    matched_arg <- match.arg(method[i], choices = c(
      "t", "gaussian", "beta", "binomial",
      "lognormal", "lognormal2", "poisson", "negbin",
      "vonmises", "vonmises2",
      "uniform", "pareto", "gamma", "bernoulli", "exponential",
      "bivariate_uniform", "bivariate_gaussian", "bivariate_lognormal"
    ))
    matched_fun <- get(paste0(".conj_", matched_arg, "_", vec_suffix))
    res <- matched_fun(sample, prior, plot, support, cred.int.level)
    return(res)
  })
  #* `combine results into an object to return`
  out <- list()
  out$summary <- do.call(cbind, lapply(seq_along(sample_results), function(i) {
    s <- sample_results[[i]]$summary
    if (i == 2) {
      s <- s[, !grepl("param", colnames(s))]
      colnames(s) <- gsub("1", "2", colnames(s))
    }
    s
  }))
  if (!is.null(s2)) {
    postProbRes <- .pdf.handling(sample_results[[1]]$pdf, sample_results[[2]]$pdf, hypothesis)
    out$summary <- cbind(
      out$summary,
      data.frame("hyp" = hypothesis, "post.prob" = as.numeric(postProbRes$post.prob))
    )
    dirSymbol <- postProbRes$direction
  } else {
    dirSymbol <- NULL
  }
  #* `parse output and do ROPE`
  if (!is.null(rope_range)) {
    rope_res <- .conj_rope(sample_results, rope_range, rope_ci, plot, method)
    out$summary <- cbind(out$summary, rope_res$summary)
  } else {
    rope_res <- NULL
  }
  out$posterior <- lapply(sample_results, function(s) s$posterior)

  #* `Make plot`
  if (plot) {
    out$plot <- .conj_plot(sample_results, rope_res,
      res = out,
      rope_range, rope_ci, dirSymbol, support, method
    )
  }
  return(out)
}

#' ***********************************************************************************************
#' *************** `Formula Handling Helper function` ***********************************
#' ***********************************************************************************************

#' @keywords internal
#' @noRd

.formatSamples <- function(s1 = NULL, s2 = NULL) {
  if (methods::is(s1, "formula")) {
    if (!is.data.frame(s2)) {
      stop("If s1 is a formula then s2 must be a data.frame")
    }
    rhs <- as.character(s1)[3]
    lhs <- as.character(s1)[2]
    if (lhs %in% colnames(s2)) { # handle SV traits
      samples <- split(s2[[lhs]], s2[[rhs]])
    } else { # handle MV traits
      samples <- lapply(split(s2, s2[[rhs]]), function(d) {
        d[, eval(str2lang(lhs))]
      })
    }
    names(samples) <- c("s1", "s2")
    return(samples)
  } else {
    return(list("s1" = s1, "s2" = s2))
  }
}

#' ***********************************************************************************************
#' *************** `MV Sample Formatting Helper function` ***********************************
#' ***********************************************************************************************

#' @keywords internal
#' @noRd

.mvSampleFormatting <- function(sample) {
  #* `Standardize sample class and names`
  if (is.matrix(sample)) {
    original_names <- colnames(sample)
    sample <- as.data.frame(sample)
    colnames(sample) <- original_names
  }
  if (is.null(colnames(sample))) {
    bins <- (seq_along(sample))
    colnames(sample) <- paste0("b", bins)
    warning(paste0("Assuming unnamed columns represent bins from ", min(bins), " to ", max(bins)))
  }
  return(sample)
}

#' ***********************************************************************************************
#' *************** `Support Calculating function` ***********************************
#' ***********************************************************************************************
#'
#'
#' @keywords internal
#' @noRd


.getSupport <- function(samplesList, method, priors) {
  #* `Check for bivarate`
  if (any(grepl("bivariate", method[1]))) {
    biv <- TRUE
  } else {
    biv <- FALSE
  }
  support_quantiles <- lapply(seq_along(samplesList), function(i) {
    sample <- samplesList[[i]]
    prior <- priors[[i]]
    #* `Check sample class`
    if (is.matrix(sample) | is.data.frame(sample)) {
      vec <- FALSE
    } else if (is.vector(sample)) {
      vec <- TRUE
    }
    vec_suffix <- if (vec) {
      "sv"
    } else {
      "mv"
    }
    matched_fun <- get(paste0(".conj_", method[i], "_", vec_suffix))
    qnts <- matched_fun(s1 = sample, priors = prior, calculatingSupport = TRUE)
    return(qnts)
  })
  if (biv) {
    pars <- names(support_quantiles[[1]])
    support <- lapply(pars, function(param) {
      qnts <- range(unlist(lapply(support_quantiles, function(sq) {
        sq[[param]]
      })))
      seq(qnts[1], qnts[2], length.out = 10000)
    })
    names(support) <- pars
  } else {
    qnts <- range(unlist(support_quantiles))
    support <- seq(qnts[1], qnts[2], length.out = 10000)
  }
  return(support)
}



#' ***********************************************************************************************
#' *************** `ROPE testing on two conjugateHelper outputs` ***********************************
#' ***********************************************************************************************
#'
#' this should take outputs from conjHelpers and compare the $posteriorDraws.
#' @keywords internal
#' @noRd
.conj_rope <- function(sample_results, rope_range = c(-0.1, 0.1),
                       rope_ci = 0.89, plot, method) {
  #* `if bivariate then call the bivariate option`
  #* note this will return to .conj_rope but with a non-bivariate method
  if (any(grepl("bivariate", method))) {
    rope_res <- .conj_bivariate_rope(
      sample_results, rope_range,
      rope_ci, plot, method
    )
    return(rope_res)
  }
  #* `ROPE Comparison`
  rope_res <- list()
  if (!is.null(rope_range)) {
    if (length(rope_range) == 2) {
      post1 <- sample_results[[1]]$posteriorDraws
      if (length(sample_results) == 2) {
        post2 <- sample_results[[2]]$posteriorDraws
        if (any(grepl("vonmises", method))) {
          boundary <- sample_results[[1]]$posterior$boundary
          posterior <- .conj_rope_circular_diff(post1, post2, boundary = boundary)
        } else {
          posterior <- post1 - post2
        }
      } else {
        posterior <- post1
      }
      hdi_diff <- as.numeric(bayestestR::hdi(posterior, ci = rope_ci))[2:3]
      hde_diff <- median(posterior)
      rope_prob <- as.numeric(bayestestR::rope(posterior,
        range = rope_range,
        ci_method = "HDI", ci = rope_ci
      ))
      rope_test <- data.frame(
        HDE_rope = hde_diff, HDI_rope_low = hdi_diff[1],
        HDI_rope_high = hdi_diff[2], rope_prob = rope_prob
      )
      rope_res$summary <- rope_test
      if (plot) {
        rope_res$rope_df <- data.frame("X" = posterior)
      }
    } else {
      stop("rope must be a vector of length 2")
    }
  }
  return(rope_res)
}

#' ***********************************************************************************************
#' *************** `ROPE testing on two conjugate_bivariate_Helper outputs` ********************
#' ***********************************************************************************************
#'
#' this should take outputs from conjHelpers and compare the $posteriorDraws.
#' @keywords internal
#' @noRd
.conj_bivariate_rope <- function(sample_results, rope_range = c(-0.1, 0.1),
                                 rope_ci = 0.89, plot, method) {
  #* `Format rope_range`
  rope_res <- list()
  if (!is.list(rope_range)) {
    rope_range <- lapply(sample_results[[1]]$summary$param, function(par) {
      rope_range
    })
    names(rope_range) <- sample_results[[1]]$summary$param
  }
  #* `ROPE Comparison`
  rope_res <- lapply(names(rope_range), function(nm) {
    iter_rope_range <- rope_range[[nm]]
    sample_results_param <- lapply(sample_results, function(s_res) {
      s_res$posteriorDraws <- s_res$posteriorDraws[[nm]]
      s_res$pdf <- s_res$pdf[[nm]]
      s_res$summary <- s_res$summary[s_res$summary$param == nm, ]
      s_res$plot_df <- s_res$plot_df[s_res$plot_df$param == nm, ]
      s_res
    })
    .conj_rope(sample_results_param,
      rope_range = iter_rope_range,
      rope_ci = rope_ci, plot, method = "NONE"
    )
  })
  rope_res$summary <- do.call(rbind, lapply(rope_res, function(r) {
    r$summary
  }))
  return(rope_res)
}

#' ***********************************************************************************************
#' *************** `Handle PDFs for testing` ***********************************
#' ***********************************************************************************************
#' @keywords internal
#' @noRd

.pdf.handling <- function(pdf1, pdf2, hypothesis) {
  if (is.list(pdf1) && is.list(pdf2)) {
    pdf.handling.output <- as.data.frame(do.call(rbind, lapply(seq_along(pdf1), function(i) {
      .post.prob.from.pdfs(pdf1[[i]], pdf2[[i]], hypothesis)
    })))
  } else {
    pdf.handling.output <- as.data.frame(.post.prob.from.pdfs(pdf1, pdf2, hypothesis))
  }
  return(pdf.handling.output)
}

#' ***********************************************************************************************
#' *************** `Calculate Posterior Probability given PDFs` ***********************************
#' ***********************************************************************************************

#' @keywords internal
#' @noRd
.post.prob.from.pdfs <- function(pdf1, pdf2, hypothesis) {
  if (hypothesis == "unequal") {
    post.prob <- 1 - sum(apply(cbind(pdf1, pdf2), MARGIN = 1, function(i) min(i)), na.rm = TRUE)
    dirSymbol <- "!="
  } else if (hypothesis == "equal") {
    post.prob <- sum(apply(cbind(pdf1, pdf2), MARGIN = 1, function(i) min(i)), na.rm = TRUE)
    dirSymbol <- "="
  } else if (hypothesis == "lesser") { # note one sided testing is less tested generally
    direction <- pdf1 <= pdf2
    post.prob <- sum(pdf1 * direction, na.rm = TRUE)
    dirSymbol <- "<"
  } else if (hypothesis == "greater") {
    direction <- pdf1 >= pdf2
    post.prob <- sum(pdf1 * direction, na.rm = TRUE)
    dirSymbol <- ">"
  } else {
    stop("hypothesis must be either unequal, equal, lesser, or greater")
  }
  return(list("post.prob" = post.prob, "direction" = dirSymbol))
}

#' ***********************************************************************************************
#' *************** `General Plotting Function` ***********************************
#' ***********************************************************************************************
#' Used to pick which kind of plotting function to use.
#' @keywords internal
#' @noRd

.conj_plot <- function(sample_results, rope_res = NULL, res,
                       rope_range, rope_ci, dirSymbol = NULL, support, method) {
  if (any(grepl("bivariate", method))) {
    .conj_bivariate_plot(sample_results, rope_res, res, rope_range, rope_ci, dirSymbol)
  } else {
    .conj_general_plot(sample_results, rope_res, res, rope_range, rope_ci, dirSymbol, support)
  }
}

#' ***********************************************************************************************
#' *************** `General Plotting Function` ***********************************
#' ***********************************************************************************************


#' @keywords internal
#' @noRd
.conj_general_plot <- function(sample_results, rope_res = NULL, res,
                               rope_range, rope_ci, dirSymbol = NULL, support) {
  s1_plot_df <- sample_results[[1]]$plot_df

  p <- ggplot2::ggplot(s1_plot_df, ggplot2::aes(x = .data$range, y = .data$prob)) +
    ggplot2::geom_area(data = s1_plot_df, alpha = 0.5, ggplot2::aes(fill = "s1")) +
    ggplot2::geom_vline(ggplot2::aes(xintercept = res$summary$HDI_1_low),
      color = "red",
      linewidth = 1.1
    ) +
    ggplot2::geom_vline(ggplot2::aes(xintercept = res$summary$HDE_1),
      color = "red", linetype = "dashed", linewidth = 1.1
    ) +
    ggplot2::geom_vline(ggplot2::aes(xintercept = res$summary$HDI_1_high),
      color = "red",
      linewidth = 1.1
    ) +
    ggplot2::scale_fill_manual(values = "red") +
    ggplot2::labs(
      x = "Posterior Distribution of Random Variable", y = "Density", title = "Distribution of Samples",
      subtitle = paste0(
        "HDE: ", round(res$summary$HDE_1, 2),
        "\nHDI: [", round(res$summary$HDI_1_low, 2), ", ",
        round(res$summary$HDI_1_high, 2), "]"
      )
    ) +
    ggplot2::guides(fill = ggplot2::guide_legend(override.aes = list(alpha = 0.5))) +
    ggplot2::theme(
      legend.title = ggplot2::element_blank(),
      legend.position = "inside",
      legend.position.inside = c(0.9, 0.9)
    ) +
    pcv_theme()

  if (length(sample_results) == 2) {
    s2_plot_df <- sample_results[[2]]$plot_df

    if (res$summary$post.prob < 1e-5) {
      post.prob.text <- "<1e-5"
    } else {
      post.prob.text <- round(res$summary$post.prob, 5)
    }

    fill_scale <- which(sapply(p$scales$scales, function(x) {
      "fill" %in% x$aesthetics # avoid "replacing scale" non-messages that suppress doesn't catch
    }))

    p$scales$scales[[fill_scale]] <- NULL
    p <- p +
      ggplot2::geom_area(data = s2_plot_df, ggplot2::aes(fill = "s2"), alpha = 0.5) +
      ggplot2::geom_vline(ggplot2::aes(xintercept = res$summary$HDI_2_low),
        color = "blue",
        linewidth = 1.1
      ) +
      ggplot2::geom_vline(ggplot2::aes(xintercept = res$summary$HDE_2),
        color = "blue",
        linetype = "dashed", linewidth = 1.1
      ) +
      ggplot2::geom_vline(ggplot2::aes(xintercept = res$summary$HDI_2_high),
        color = "blue",
        linewidth = 1.1
      ) +
      ggplot2::scale_fill_manual(values = c("red", "blue"), breaks = c("s1", "s2")) +
      ggplot2::guides(fill = ggplot2::guide_legend(override.aes = list(alpha = 0.5))) +
      ggplot2::theme(
        legend.title = ggplot2::element_blank(),
        legend.position = "inside",
        legend.position.inside = c(0.9, 0.9)
      ) +
      ggplot2::labs(subtitle = paste0(
        "Sample 1:  ", round(res$summary$HDE_1, 2), " [", round(res$summary$HDI_1_low, 2), ", ",
        round(res$summary$HDI_1_high, 2), "]\n",
        "Sample 2:  ", round(res$summary$HDE_2, 2), " [", round(res$summary$HDI_2_low, 2), ", ",
        round(res$summary$HDI_2_high, 2), "]\n",
        "P[p1", dirSymbol, "p2] = ", post.prob.text
      ))
  }

  if (!is.null(rope_res)) {
    rdf <- rope_res$rope_df
    p <- p + ggplot2::ggplot(rdf, ggplot2::aes(x = .data$X)) +
      ggplot2::geom_histogram(bins = 100, fill = "purple", color = "purple", alpha = 0.7) +
      ggplot2::geom_histogram(
        data = data.frame(
          "X" = rdf[
            rdf$X > rope_range[1] &
              rdf$X < rope_range[2] &
              rdf$X > res$summary$HDI_rope_low &
              rdf$X < res$summary$HDI_rope_high,
          ]
        ),
        bins = 100, fill = "gray30", color = "gray30"
      ) +
      ggplot2::annotate("segment",
        x = rope_range[1], xend = rope_range[2], y = 0, yend = 0,
        linewidth = 2, color = "gray70"
      ) +
      ggplot2::geom_vline(ggplot2::aes(xintercept = res$summary$HDI_rope_low), linewidth = 0.7) +
      ggplot2::geom_vline(ggplot2::aes(xintercept = res$summary$HDE_rope),
        linetype = "dashed",
        linewidth = 0.7
      ) +
      ggplot2::geom_vline(ggplot2::aes(xintercept = res$summary$HDI_rope_high), linewidth = 0.7) +
      ggplot2::labs(
        x = "Posterior of Difference", y = "Frequency", title = "Distribution of Difference",
        subtitle = paste0(
          "Median Difference of ", round(res$summary$HDE_rope, 2), "\n",
          100 * rope_ci, "% CI [", round(res$summary$HDI_rope_low, 2), ", ",
          round(res$summary$HDI_rope_high, 2), "]\n",
          rope_ci, "% HDI in [", rope_range[1], ", ", rope_range[2], "]: ",
          round(res$summary$rope_prob, 2)
        )
      ) +
      pcv_theme() +
      ggplot2::theme(
        axis.title.y.left = ggplot2::element_blank(),
        axis.text.y.left = ggplot2::element_blank()
      ) +
      patchwork::plot_layout(widths = c(2, 1))
  }
  return(p)
}


#' ***********************************************************************************************
#' *************** `Bivariate Plotting Function` ***********************************
#' ***********************************************************************************************
#'
#' @keywords internal
#' @noRd

.conj_bivariate_plot <- function(sample_results, rope_res = NULL, res,
                                 rope_range, rope_ci, dirSymbol = NULL, support) {
  TITLE <- "Joint Posterior Distribution"
  if (length(sample_results) == 1) {
    margin_plot_df <- sample_results[[1]]$plot_df
    params <- unique(margin_plot_df$param)
    #* `Make joint distribution plot`
    joint_dist_s1 <- sample_results[[1]]$posteriorDraws
    limits <- lapply(params, function(p) {
      sub <- margin_plot_df[margin_plot_df$param == p, ]
      range(sub$range)
    })
    names(limits) <- params
    x_lim <- limits[[1]]
    y_lim <- limits[[2]]
    v_lines <- res$summary[res$summary$param == params[1], ]
    h_lines <- res$summary[res$summary$param == params[2], ]

    joint_p <- ggplot2::ggplot(
      joint_dist_s1,
      ggplot2::aes(
        x = .data[[params[1]]], y = .data[[params[2]]],
        group = .data[["sample"]]
      )
    ) +
      ggplot2::geom_hline(
        yintercept = h_lines$HDI_1_low, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      ggplot2::geom_hline(
        yintercept = h_lines$HDI_1_high, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      ggplot2::geom_vline(
        xintercept = v_lines$HDI_1_low, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      ggplot2::geom_vline(
        xintercept = v_lines$HDI_1_high, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      geom_density_2d_filled(breaks = ~ pretty(., n = 51)[-1], alpha = 0.9) +
      ggplot2::scale_fill_viridis_d(option = "plasma") +
      ggplot2::xlim(x_lim) +
      ggplot2::ylim(y_lim) +
      pcv_theme() +
      ggplot2::theme(legend.position = "none")
    #* `Make marginal distribution plot of each parameter (x, y)`
    margin_plots <- lapply(params, function(par) {
      ggplot2::ggplot(
        margin_plot_df[margin_plot_df$param == par, ],
        ggplot2::aes(x = .data$range, y = .data$prob)
      ) +
        ggplot2::geom_area(
          data = margin_plot_df[margin_plot_df$param == par, ],
          alpha = 0.5, ggplot2::aes(fill = "s1")
        ) +
        ggplot2::geom_vline(
          data = data.frame(),
          ggplot2::aes(
            xintercept = res$summary[res$summary$param == par, "HDI_1_low"]
          ),
          color = "red",
          linewidth = 0.5
        ) +
        ggplot2::geom_vline(
          data = data.frame(),
          ggplot2::aes(
            xintercept = res$summary[res$summary$param == par, "HDE_1"]
          ),
          color = "red", linetype = "dashed", linewidth = 0.5
        ) +
        ggplot2::geom_vline(
          data = data.frame(),
          ggplot2::aes(
            xintercept = res$summary[res$summary$param == par, "HDI_1_high"]
          ),
          color = "red", linetype = "dashed", linewidth = 0.5
        ) +
        ggplot2::scale_fill_manual(values = "red") +
        ggplot2::xlim(limits[[par]]) +
        ggplot2::theme_void() +
        ggplot2::theme(legend.title = ggplot2::element_blank())
    })
    #* `Write title if there is only 1 sample`
    SUBTITLE <- NULL
  } else if (length(sample_results) == 2) {
    #* `Make plots for sample 2 if it exists`
    margin_plot_df <- do.call(rbind, lapply(1:2, function(i) {
      md <- sample_results[[i]]$plot_df
      md$sample <- paste0("Sample ", i)
      md
    }))
    params <- unique(margin_plot_df$param)
    joint_dist <- do.call(rbind, lapply(1:2, function(i) {
      pd <- sample_results[[i]]$posteriorDraws
      pd$sample <- paste0("Sample ", i)
      pd
    }))
    #* `Define Limits`
    limits <- lapply(params, function(p) {
      sub <- margin_plot_df[margin_plot_df$param == p, ]
      range(sub$range)
    })
    names(limits) <- params
    x_lim <- limits[[1]]
    y_lim <- limits[[2]]
    #* `Make joint distribution plot`
    v_lines <- res$summary[res$summary$param == params[1], ]
    h_lines <- res$summary[res$summary$param == params[2], ]

    joint_p <- ggplot2::ggplot(
      joint_dist,
      ggplot2::aes(
        x = .data[[params[1]]], y = .data[[params[2]]],
        group = .data[["sample"]]
      )
    ) +
      ggplot2::geom_hline(
        yintercept = h_lines$HDI_1_low, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      ggplot2::geom_hline(
        yintercept = h_lines$HDI_1_high, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      ggplot2::geom_hline(
        yintercept = h_lines$HDI_2_low, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      ggplot2::geom_hline(
        yintercept = h_lines$HDI_2_high, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      ggplot2::geom_vline(
        xintercept = v_lines$HDI_1_low, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      ggplot2::geom_vline(
        xintercept = v_lines$HDI_1_high, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      ggplot2::geom_vline(
        xintercept = v_lines$HDI_2_low, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      ggplot2::geom_vline(
        xintercept = v_lines$HDI_2_high, color = "gray80", linetype = 5,
        linewidth = 0.25
      ) +
      geom_density_2d_filled(breaks = ~ pretty(., n = 51)[-1], alpha = 0.9) +
      ggplot2::scale_fill_viridis_d(option = "plasma") +
      ggplot2::xlim(x_lim) +
      ggplot2::ylim(y_lim) +
      pcv_theme() +
      ggplot2::theme(legend.position = "none")

    #* `Make marginal distribution plot of each parameter (x, y)`
    margin_plots <- lapply(params, function(par) {
      hdf <- res$summary
      hdf <- hdf[hdf$param == par, ]
      ggplot2::ggplot() +
        ggplot2::geom_area(
          data = margin_plot_df[margin_plot_df$param == par, ],
          alpha = 0.5, ggplot2::aes(
            x = .data$range, y = .data$prob,
            fill = .data$sample
          ),
          position = "identity"
        ) +
        ggplot2::geom_vline(
          data = data.frame(),
          ggplot2::aes(
            xintercept = hdf[, "HDI_1_low"]
          ),
          color = "red", linetype = "dashed",
          linewidth = 0.5
        ) +
        ggplot2::geom_vline(
          data = data.frame(),
          ggplot2::aes(
            xintercept = hdf[, "HDE_1"]
          ),
          color = "red", linewidth = 0.5
        ) +
        ggplot2::geom_vline(
          data = data.frame(),
          ggplot2::aes(
            xintercept = hdf[, "HDI_1_high"]
          ),
          color = "red", linetype = "dashed", linewidth = 0.5
        ) +
        ggplot2::geom_vline(
          data = data.frame(),
          ggplot2::aes(
            xintercept = hdf[, "HDI_2_low"]
          ),
          color = "blue", linetype = "dashed",
          linewidth = 0.5
        ) +
        ggplot2::geom_vline(
          data = data.frame(),
          ggplot2::aes(
            xintercept = hdf[, "HDE_2"]
          ),
          color = "blue", linewidth = 0.5
        ) +
        ggplot2::geom_vline(
          data = data.frame(),
          ggplot2::aes(
            xintercept = hdf[, "HDI_2_high"]
          ),
          color = "blue", linetype = "dashed", linewidth = 0.5
        ) +
        ggplot2::scale_fill_manual(values = c("red", "blue")) +
        ggplot2::xlim(limits[[par]]) +
        ggplot2::theme_void() +
        ggplot2::theme(
          legend.position = "inside",
          legend.position.inside = c(0.1, 0.5),
          legend.title = ggplot2::element_blank()
        )
    })

    post.probs <- lapply(params, function(par) {
      hdf <- res$summary
      hdf <- hdf[hdf$param == par, ]
      if (hdf$post.prob < 1e-5) {
        post.prob.text <- "<1e-5"
      } else {
        post.prob.text <- round(hdf$post.prob, 5)
      }
      return(post.prob.text)
    })
    names(post.probs) <- params

    #* `Write title if there are 2 samples`
    SUBTITLE <- paste(lapply(params, function(par) {
      paste0(par, ": P[s1", dirSymbol[[1]], "s2] = ", post.probs[[par]])
    }), collapse = "\n")
  }
  #* `Assemble Patchwork`
  layout <- c(
    patchwork::area(2, 1, 3, 2),
    patchwork::area(1, 1, 1, 2),
    patchwork::area(2, 3, 3, 3)
  )
  margin_plots[[2]] <- margin_plots[[2]] +
    ggplot2::coord_flip() +
    ggplot2::theme(legend.position = "none")

  p <- joint_p + margin_plots[[1]] + margin_plots[[2]] +
    patchwork::plot_layout(design = layout) &
    patchwork::plot_annotation(title = TITLE, subtitle = SUBTITLE)
  return(p)
}

#' Function to run a PCA, plot and optionally return the data with PCA coordinates and pca object
#'
#' @param df Dataframe to ordinate
#' @param cols columns to reduce dimensions of. Can be specified with names or positions.
#' If this is length of 1 then it is treated as regex pattern to match
#' the column names that should be used.
#' @param color column name(s) used to color points in the pca plot.
#' @param facet Optional column or vector to facet plots on.
#' @param returnData Logical, should data be returned?
#' @param ncp Optional, number of principal components to return attached
#'  to dataframe if data is returned. Defaults to all.
#' @keywords pca
#' @details If data is returned then it will contain the coordinates from the
#'  PCA and will not contain the columns that were reduced.
#'
#' @import ggplot2
#' @import FactoMineR
#' @importFrom stats as.formula
#' @return A ggplot or list with a ggplot, a dataframe with the data and PCs, and the factominer
#' PCA object as elements.
#' @examples
#'
#' dists <- list(
#'   rlnorm = list(meanlog = log(40), sdlog = 0.5),
#'   rnorm = list(mean = 60, sd = 10)
#' )
#' mv <- mvSim(
#'   dists = dists, n_samples = 100, counts = 1000,
#'   min_bin = 1, max_bin = 180, wide = TRUE
#' )
#' mv$otherGroup <- sample(c("a", "b"), size = nrow(mv), replace = TRUE)
#' pcadf(mv, cols = "sim_", returnData = TRUE)
#' pcadf(mv, cols = 2:181, color = c("group", "otherGroup"), returnData = FALSE)
#'
#' @export

pcadf <- function(df = NULL, cols = NULL, color = NULL,
                  facet = NULL, returnData = TRUE, ncp = NULL) {
  if (is.character(cols) && length(cols) == 1) {
    cols <- which(grepl(cols, colnames(df)))
  }
  if (!is.null(color) && length(color) > 1) {
    df[[paste(color, collapse = ".")]] <- interaction(df[, color])
    color <- paste(color, collapse = ".")
  }
  if (is.null(ncp)) {
    ncp <- min(dim(df[, cols])) - 1
  }
  pca <- FactoMineR::PCA(df[, cols], ncp = ncp, graph = FALSE)
  pc1Var <- round(pca$eig[1, 2], 3)
  pc2Var <- round(pca$eig[2, 2], 3)
  coords <- as.data.frame(pca$ind)
  coords <- coords[, grepl("coord", colnames(coords))]
  colnames(coords) <- gsub("coord.Dim.", "pc", colnames(coords))
  if (!is.numeric(cols)) {
    cols <- which(colnames(df) %in% cols)
  }
  pca.df <- cbind(as.data.frame(df[, -cols]), coords)
  colnames(pca.df)[1:(length(colnames(df)) - length(cols))] <- colnames(df)[-cols]
  facetLayer <- NULL
  if (!is.null(facet)) {
    facetLayer <- ggplot2::facet_wrap(as.formula(paste0("~", paste(facet, collapse = "+"))))
  }

  if (is.null(color)) {
    pca.df$dummyVariableForColor <- 1
    color <- "dummyVariableForColor"
  }

  plots <- .pcaGeneralPlot(pca.df, color, facetLayer, pc1Var, pc2Var)

  if (returnData) {
    return(list("data" = pca.df, "pca" = pca, "plot" = plots))
  } else {
    return(plots)
  }
}

#' general pca plotting
#' @keywords internal
#' @noRd

.pcaGeneralPlot <- function(pca.df, color, facetLayer, pc1Var, pc2Var) {
  plots <- ggplot2::ggplot(pca.df, ggplot2::aes(
    x = .data$pc1,
    y = .data$pc2, color = .data[[color]]
  )) +
    ggplot2::geom_point() +
    ggplot2::labs(x = paste0("PC 1 (", pc1Var, "%)"), y = paste0("PC 2 (", pc2Var, "%)")) +
    pcv_theme()
  if (color == "dummyVariableForColor") {
    plots <- plots + ggplot2::theme(legend.position = "none")
  }
  plots <- plots + facetLayer
  return(plots)
}

#' Function to reshape phenotype data to survival data based on some pcvrForm
#'
#' @param df a dataframe to use
#' @param form a formula describing the survival analysis model (see growthSS)
#' @param model The distribution to use (model from .survModelParser )
#'
#' @return A list including a dataframe and elements of the formula parsed.
#'
#' @examples
#'
#' df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' form <- y > 100 ~ time | id / group
#' model = "weibull" # or binomial
#' .makeSurvData(df, form, model)
#'
#' @keywords internal
#' @noRd

.makeSurvData <- function(df, form, model = "weibull") {
  #* `general pcvr formula parsing`
  parsed_form <- .parsePcvrForm(form, df)
  y <- parsed_form$y
  x <- parsed_form$x
  individual <- parsed_form$individual
  group <- parsed_form$group
  df <- parsed_form$data
  #* `further survival formula steps`
  y_var <- trimws(strsplit(y, ">|[|]")[[1]][1])
  y_condition <- as.numeric(trimws(strsplit(y, ">|[|]")[[1]][2]))
  df[[y_var]] <- as.numeric(df[[y_var]] >= y_condition)

  df$remove_interaction <- interaction(df[[individual]], df[[group]])

  if (model == "weibull") {
    out_df <- do.call(rbind, lapply(unique(df$remove_interaction), function(i) {
      sub <- df[df$remove_interaction == i, ]
      sub$censor <- ifelse(sub[[x]] == max(df[[x]]) & sub[[y_var]] == 0, 1, 0)
      sub[sub$censor == 1 | sub[[x]] == min(c(sub[sub[[y_var]] == 1, x], Inf)), ]
    }))
    colnames(out_df)[which(colnames(out_df) == y_var)] <- "event"
  } else if (model == "binomial") {
    out_df <- do.call(rbind, lapply(unique(df[[x]]), function(time) {
      sub <- df[df[[x]] == time, ]
      if (time != unique(df[[x]])[1]) {
        prev <- df[df[[x]] == time - 1, ]
      } else {
        prev <- sub
      }
      lt <- stats::setNames(
        aggregate(as.formula(paste0(y_var, " ~ ", group)), sub, sum),
        c("group", "n_events")
      )
      lt$n_no_event <- aggregate(as.formula(paste0(y_var, " ~ ", group)), sub, function(x) {
        sum(x == 0)
      })[, 2]
      lt$n_eligible <- aggregate(as.formula(paste0(y_var, " ~ ", group)), prev, length)[, 2]
      lt$pct_event <- lt$n_events / lt$n_eligible
      lt[[x]] <- time
      lt
    }))
    out_df[[x]] <- factor(out_df[[x]])
  }
  out_df <- out_df[, !grepl("remove_interaction", colnames(out_df))]
  ret <- list(
    "data" = out_df, "y_var" = y_var, "y_cutoff" = y_condition,
    "x" = x, "group" = group, "individual" = individual
  )
  return(ret)
}

#' Helper function to check groups in data.
#'
#' @param df Data frame to use.
#' @param group Set of variables to use in grouping observations.
#' These taken together should identify a unique plant (or unique plant at a unique angle) across time.
#' @return If there are duplicates in the grouping then this will return a message with code to start
#' checking the duplicates in your data.
#'
#' @examples
#'
#' df <- growthSim("linear",
#'   n = 10, t = 10,
#'   params = list("A" = c(2, 1.5))
#' )
#' checkGroups(df, c("time", "id", "group"))
#' df$time[12] <- 3
#' checkGroups(df, c("time", "id", "group"))
#'
#' @export

checkGroups <- function(df, group) {
  tab <- table(interaction(df[, c(group)]))
  if (any(tab > 1)) {
    dataname <- deparse(substitute(df))
    nms <- names(tab)[which(as.numeric(tab) > 1)]
    dupString <- paste0(
      dataname,
      "[duplicated(interaction(",
      paste(paste0(dataname, "$", c(group)), collapse = ", "),
      ")),]"
    )
    firstDup <- paste0(
      dataname, "[interaction(",
      paste(paste0(
        dataname, "$",
        c(group)
      ), collapse = ", "), ")=='",
      nms[1], "',]"
    )
    eval(parse(text = dupString))
    w <- paste0(
      "There are ", length(nms), " observations that are not uniquely identified.",
      "\nThe max number of duplicates is ",
      max(tab, na.rm = TRUE), ".\nRun `", dupString, "` to see the duplicated rows,\n",
      " or ", firstDup, " to see the first duplicated instance."
    )
    message(w)
  } else {
    message("Grouping is unique")
  }
}

#' Function to visualize hypotheses tested on brms models similar to those made using growthSS outputs.
#'
#'
#'
#' @param fit A brmsfit object or a list of brmsfit objects
#' @param params A list of parameters to use from the fit.
#' Defaults to NULL in which case all growth model parameters are used.
#' @param hyp A character string defining the hypothesis to be tested.
#' Defaults to "num/denom > 1.05". The "num" and "denom" names should be kept,
#' but the direction and magnitude can be changed.
#' @param compareX Which groups in the model should be compared as numerator options?
#' Defaults to NULL in which case a plot will not be made but the data will be returned.
#' @param againstY Which group in the model should be used as the
#' denominator (typically a control group to compare against)?
#' Defaults to NULL in which case a plot will not be made but the data will be returned.
#' @param group_sep A regex pattern to match the separation of grouping
#' terms in the models group term (see the formula argument of \code{\link{growthSS}}).
#' The default uses "[.]" to break on a single period.
#' @param groups_into A vector of column names to make after groups are split by group_sep.
#' If this or groups_sep are NULL then no groups are assumed.
#' @param x The variable to be plotted on the x axis (should be from groups_into).
#' @param facet The variable to be used to facet the
#' ggplot (should be another option from groups_into).
#' If left NULL then the plot will only be faceted by params.
#' Note that with the nature of againstY this faceting is often redundant
#' but it does add labels which are helpful for keeping results organized..
#' @param cores Optional number of cores to run hypotheses in parallel.
#' Defaults to 1 unless the "mc.cores" option is set.
#' @param returnData Logical, should data be returned?
#' This is treated as TRUE if a plot will not be generated but
#' otherwise defaults to FALSE.
#'
#' @keywords brms ggplot2
#'
#' @import ggplot2
#' @import viridis
#' @import parallel
#' @importFrom utils combn
#' @importFrom stats as.formula setNames
#'
#' @examples
#' \donttest{
#' set.seed(123)
#' simdf <- growthSim(
#'   "logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group, sigma = "spline",
#'   list("A" = 130, "B" = 10, "C" = 3),
#'   df = simdf, type = "brms"
#' )
#'
#' fit <- fitGrowth(ss, backend = "cmdstanr", iter = 500, chains = 1, cores = 1)
#' brmViolin(fit,
#'   hyp = "num/denom>1.05",
#'   compareX = "a",
#'   againstY = "b", returnData = TRUE
#' )
#' }
#'
#' @return Returns a ggplot showing a brms model's posterior distributions
#' as violins and filled by posterior probability of some hypothesis.
#'
#' @export

brmViolin <- function(fit, params = NULL, hyp = "num/denom>1.05", compareX = "a", againstY = "b",
                      group_sep = "[.]", groups_into = c("group2"), x = NULL, facet = NULL,
                      cores = getOption("mc.cores", 1), returnData = FALSE) {
  #* `parse arguments`
  model <- fit
  brmViolinParseArgumentsRes <- .brmViolinParseArguments(
    compareX, againstY,
    model, params, group_sep,
    groups_into
  )
  compareFew <- brmViolinParseArgumentsRes[["compareFew"]]
  compareX <- brmViolinParseArgumentsRes[["compareX"]]
  model <- brmViolinParseArgumentsRes[["model"]]
  params <- brmViolinParseArgumentsRes[["params"]]
  useGroups <- brmViolinParseArgumentsRes[["useGroups"]]
  if (is.null(x)) {
    x <- groups_into[1]
  }
  #* `get draws`
  draws <- do.call(cbind, lapply(model, function(mod) { # extract draws for relevant parameters
    mdf <- as.data.frame(mod[["fit"]])
    colPattern <- paste0("^b_[", paste0(params, collapse = "|"), "]")
    mdf <- mdf[, grepl(colPattern, colnames(mdf))]
    colnames(mdf) <- sub("^b_", "", colnames(mdf))
    mdf
  }))
  #* take "grouping" string from formula (pform) and using that with the parameter names I can find
  #* groups for any models?
  #* For models fit with only one group of many from data this would fail, I'll need another option
  #* for that.
  #* probably fine to build this out first then think about how that edge case works.
  group_string <- trimws(
    strsplit(
      as.character(model[[1]]$formula$pforms[[params[1]]])[3], "[+]"
    )[[1]]
  )[2]

  groupings <- unique(sub(paste0(".*", group_string), "", colnames(draws)))
  p1 <- combn(groupings, 2, simplify = FALSE)
  p2 <- lapply(p1, rev)
  p3 <- lapply(unique(groupings), function(g) c(g, g))
  comparisons <- c(p1, p2, p3)
  if (compareFew) {
    comparisons <- comparisons[unlist(lapply(comparisons, function(comp) {
      comp[1] %in% compareX & comp[2] == againstY
    }))]
  }

  colnames(draws) <- sub(group_string, "", colnames(draws))

  hyps_df <- do.call(rbind, lapply(params, function(param) {
    param_df <- do.call(rbind, parallel::mclapply(comparisons, function(comp) {
      num <- paste(param, comp[1], sep = "_")
      denom <- paste(param, comp[2], sep = "_")
      temp <- draws
      temp$num <- temp[[num]]
      temp$denom <- temp[[denom]]
      x <- as.data.frame(brms::hypothesis(temp, paste0(hyp))$h)
      x$param <- param
      x$num <- sub("grouping", "", comp[1])
      x$denom <- sub("grouping", "", comp[2])
      x[, c("Post.Prob", "param", "num", "denom")]
    }, mc.cores = cores))
    param_df
  }))

  hyps_df$discrete_post_prob <- factor(
    ifelse(hyps_df$Post.Prob >= 0.99, "A",
      ifelse(hyps_df$Post.Prob >= 0.95, "B",
        ifelse(hyps_df$Post.Prob >= 0.85, "C",
          ifelse(hyps_df$Post.Prob >= 0.75, "D", "E")
        )
      )
    ),
    levels = c("A", "B", "C", "D", "E"), ordered = TRUE
  )

  longdraw <- as.data.frame(data.table::melt(data.table::as.data.table(draws),
    measure.vars = colnames(draws), value.name = "draw"
  ))
  longdraw$param <- substr(longdraw$variable, 1, 1)
  longdraw$group <- sub(paste0("[", paste0(params, collapse = "|"), "]_"), "", longdraw$variable)
  if (useGroups) {
    group_meta <- do.call(rbind, parallel::mclapply(longdraw$group,
      function(g) {
        setNames(
          data.frame(t(strsplit(g, group_sep)[[1]])),
          groups_into
        )
      },
      mc.cores = cores
    ))
    for (col in groups_into) {
      group_meta[[col]] <- factor(group_meta[[col]])
    }
    longdraw <- cbind(longdraw, group_meta)
  }
  ldj <- merge(longdraw, hyps_df, by.x = c("group", "param"), by.y = c("num", "param"))

  if (!compareFew) {
    return(ldj)
  }

  virPal <- unlist(lapply(c(1, 0.9, 0.75, 0.5, 0.25), function(i) viridis::plasma(1, 1, i)))

  # still need to separate "grouping" into x and y variables.

  if (is.null(facet)) {
    facet_layer <- ggplot2::facet_wrap(~param, scales = "free_y")
  } else {
    facet_layer <- ggplot2::facet_grid(as.formula(paste0("param~", facet)), scales = "free_y")
  }

  violinPlot <- ggplot2::ggplot(ldj, ggplot2::aes(
    x = .data[[x]], y = .data[["draw"]],
    fill = .data[["discrete_post_prob"]]
  )) +
    facet_layer +
    ggplot2::geom_violin() +
    lapply(unique(ldj$param), function(p) {
      x <- data.frame(param = p, mean = mean(ldj[ldj$param == p & ldj$group == ldj$denom, "draw"]))
      ggplot2::geom_hline(data = x, ggplot2::aes(yintercept = mean), linetype = 5, linewidth = 0.5)
    }) +
    ggplot2::scale_fill_manual(
      values = virPal, breaks = c("A", "B", "C", "D", "E"),
      labels = c(">99%", ">95%", ">85%", ">75%", "<75%"), drop = TRUE
    ) +
    ggplot2::labs(y = "Posterior Distribution", x = x, fill = "Discrete Posterior Probability") +
    pcv_theme() +
    ggplot2::theme(
      legend.position = "bottom", axis.text.x.bottom = ggplot2::element_text(angle = 0, hjust = 0.5),
      panel.border = ggplot2::element_rect(fill = NA)
    )
  if (returnData) {
    return(list("plot" = violinPlot, "data" = ldj))
  } else {
    return(violinPlot)
  }
}


.brmViolinParseArguments <- function(compareX, againstY, model, params, group_sep, groups_into) {
  compareFew <- FALSE
  if (!is.null(compareX) && !is.null(againstY)) {
    compareFew <- TRUE
    if (!againstY %in% compareX) {
      compareX <- c(compareX, againstY)
    } # make sure all violins will be filled if both are provided
  }

  if (any(unlist(lapply(model, class)) != "brmsfit")) {
    # if only one brmsfit is given then make a list of itself
    model <- list(model)
  }

  if (is.null(params)) { # if params aren't given then grab all
    nlPars <- names(model[[1]]$formula$pforms)
    params <- nlPars[-which(grepl("sigma|nu", nlPars))]
  }
  useGroups <- FALSE
  if (!is.null(group_sep) || !is.null(groups_into)) {
    useGroups <- TRUE
  }
  return(list(
    "compareFew" = compareFew,
    "compareX" = compareX,
    "model" = model,
    "params" = params,
    "useGroups" = useGroups
  ))
}

#' Helper function to parse distributional formulas and return components for fitting a brms model
#'
#' @param model a model passed from growthSS
#' @param x the x variable
#' @param y the response variable
#' @param group the grouping variable
#' @param sigma Logical, is this a distributional parameter? Defaults to TRUE here.
#' @param nTimes Number of unique x values. Used for splines, if nTimes is too low then the spline knots
#' must be adjusted. Defaults to 25.
#' @param useGroup Logical, should groups be used?
#' @param priors Priors in growthSS syntax, passed to .brmsChangePointHelper for thresholded models.
#' @param int logical, should an intercept be included in the model?
#'
#' @return A list of elements to pass brmSS for fitting distributional models
#'
#'
#' @keywords internal
#' @noRd

.brmDparHelper <- function(dpar, model, x, group, nTimes, useGroup, priors, int = FALSE) {
  splineDparHelperForm <- NULL
  if (grepl("\\+", model)) {
    chngptHelperList <- .brmsChangePointHelper(model, x,
      y = dpar, group, dpar = TRUE,
      nTimes, useGroup, priors, int = int
    )
    dparForm <- chngptHelperList$growthForm
    dpar_pars <- chngptHelperList$pars
    splineDparHelperForm <- chngptHelperList$splineHelperForm
  } else {
    if (model == "homo") {
      model <- "int" # recode alternate names
    } else if (model == "spline") {
      model <- "gam"
    }
    stringBrmsDparFormFun <- paste0(".brms_form_", gsub(" ", "", model))
    brmsDparFormFun <- match.fun(stringBrmsDparFormFun)
    formResDpar <- brmsDparFormFun(x, dpar, group,
      dpar = TRUE, nTimes = nTimes,
      useGroup = useGroup, prior = priors, int = int
    )
    dparForm <- formResDpar$form
    dpar_pars <- formResDpar$pars
  }
  return(list(
    "dparForm" = dparForm, "dpar_pars" = dpar_pars,
    "dparSplineHelperForm" = splineDparHelperForm
  ))
}

#' @description
#' Internal function for calculating the pareto distribution of the upper boundary of a uniform
#' distribution represented by single value traits.
#' @param s1 A vector of numerics drawn from a uniform distribution.
#' @examples
#' set.seed(123)
#' s1 = stats::runif(10, -1, 10)
#' out <- .conj_bivariate_uniform_sv(
#'   s1 = s1, cred.int.level = 0.95,
#'   plot = TRUE
#' )
#' lapply(out, head)
#'
#' @keywords internal
#' @noRd

.conj_bivariate_uniform_sv <- function(s1 = NULL, priors = NULL,
                                       plot = FALSE, support = NULL, cred.int.level = NULL,
                                       calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  #* conjugate prior needs r1, r2, and alpha
  #* which are locations and a shared shape (scale) paramter
  if (is.null(priors)) {
    priors <- list(location_l = 1, location_u = 2, scale = 1)
  }
  #* `Update bivariate pareto prior with sufficient statistics`
  location_u_prime <- max(c(s1, priors$location_u[1]))
  location_l_prime <- min(c(s1, priors$location_l[1]))
  scale_prime <- priors$scale[1] + length(s1)
  #* `Define bivariate support if it is missing`
  #* `this will require some thought since there are two directions.`
  #* first problem is that qpareto requires the parameters to be > 0,
  #* but the lower boundary can be negative, or could be something like 1
  #* with a tail that becomes negative. I guess changing the center is the
  #* way to account for those potential problems.
  if (is.null(support)) {
    (quantiles_u <- qpareto(c(0.0001, 0.9999), scale_prime, abs(location_u_prime)))
    (quantiles_l <- qpareto(c(0.0001, 0.9999), scale_prime, abs(location_l_prime)))
    support_l <- seq(quantiles_l[1], quantiles_l[2], length.out = 10000)
    support_u <- seq(quantiles_u[1], quantiles_u[2], length.out = 10000)

    if (location_l_prime < 0) {
      quantiles_l <- -1 * rev(quantiles_l)
      support_l <- seq(quantiles_l[1], quantiles_l[2], length.out = 10000)
    }
    if (location_u_prime < 0) {
      quantiles_u <- -1 * rev(quantiles_u)
      support_u <- seq(quantiles_u[1], quantiles_u[2], length.out = 10000)
    }

    if (calculatingSupport) {
      return(list("A" = quantiles_l, "B" = quantiles_u))
    }
  } else {
    support_l <- support$A
    support_u <- support$B
  }
  #* `Make Posterior Draws`
  out$posteriorDraws <- .conj_cond_inv_rpareto(
    10000, location_l_prime, location_u_prime,
    scale_prime
  )
  #* `posterior`
  #* this also needs to handle the possibility of negative locations
  if (location_l_prime < 0) {
    dens_l <- extraDistr::dpareto(-1 * support_l, scale_prime, abs(location_l_prime))
  } else {
    dens_l <- extraDistr::dpareto(support_l, scale_prime, location_l_prime)
  }

  if (location_u_prime < 0) {
    dens_u <- extraDistr::dpareto(-1 * support_u, scale_prime, abs(location_u_prime))
  } else {
    dens_u <- extraDistr::dpareto(support_u, scale_prime, location_u_prime)
  }

  pdf_l <- dens_l / sum(dens_l)
  pdf_u <- dens_u / sum(dens_u)
  out$pdf <- list("A" = pdf_l, "B" = pdf_u)

  hde_l <- location_l_prime
  hde_u <- location_u_prime

  if (location_l_prime < 0) {
    hdi_l <- -1 * rev(extraDistr::qpareto(
      c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
      scale_prime, abs(location_l_prime)
    ))
  } else {
    hdi_l <- extraDistr::qpareto(
      c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
      scale_prime, location_l_prime
    )
  }
  if (location_u_prime < 0) {
    hdi_u <- -1 * rev(extraDistr::qpareto(
      c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
      scale_prime, abs(location_u_prime)
    ))
  } else {
    hdi_u <- extraDistr::qpareto(
      c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
      scale_prime, location_u_prime
    )
  }

  #* `Store summary`
  out$summary <- data.frame(
    HDE_1 = c(hde_l, hde_u),
    HDI_1_low = c(hdi_l[1], hdi_u[1]),
    HDI_1_high = c(hdi_l[2], hdi_u[2]),
    param = c("A", "B")
  )
  out$posterior <- list(
    "scale" = scale_prime, "location_l" = location_l_prime,
    "location_u" = location_u_prime
  )
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = c(support_l, support_u),
      "prob" = c(pdf_l, pdf_u),
      "param" = rep(c("A", "B"), each = length(support_u)),
      "sample" = rep("Sample 1", 2 * length(support_u))
    )
  }
  return(out)
}

#' @description
#' Internal function for calculating conditional inverse sampling from bivariate pareto
#' @examples
#' .conj_cond_inv_rpareto(10, 1, 2, 10)
#'
#' @keywords internal
#' @noRd

.conj_cond_inv_rpareto <- function(n, r1, r2, scale) {
  u <- stats::runif(n, min = 0, max = 1)
  # pareto quantile function
  x2 <- r2 / (u^(1 / scale))
  u <- stats::runif(n, min = 0, max = 1)
  # this is a displaced origin pareto
  # also using quantile function of the marginal x1 | x2
  x1 <- r1 + (r1 / r2) * x2 * (1 / (u^(1 / (scale + 1))) - 1)
  return(cbind.data.frame("A" = x1, "B" = x2))
}

#' @description
#' Internal function for calculating the pareto distribution of the upper boundary of a uniform
#' distribution represented by multi value traits.
#' @param s1 A vector of numerics drawn from a uniform distribution.
#' @examples
#' s1 <- mvSim(
#'   dists = list(runif = list(min = 15, max = 150)),
#'   n_samples = 10,
#'   counts = 1000,
#'   min_bin = 1,
#'   max_bin = 180,
#'   wide = TRUE
#' )
#' out <- .conj_bivariate_uniform_mv(
#'   s1 = s1[, -1], cred.int.level = 0.95,
#'   priors = list(location_l = 50, location_u = 100, scale = 1),
#'   plot = FALSE
#' )
#' lapply(out, head)
#' @keywords internal
#' @noRd

.conj_bivariate_uniform_mv <- function(s1 = NULL, priors = NULL,
                                       plot = FALSE, support = NULL, cred.int.level = NULL,
                                       calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  #* conjugate prior needs r1, r2, and alpha
  #* which are locations and a shared shape (scale) paramter
  if (is.null(priors)) {
    priors <- list(location_l = 1, location_u = 2, scale = 1)
  }
  #* `Calculate Sufficient Statistics`
  #* `N observations`
  n_obs <- nrow(s1)
  #* `Max non-zero bin`
  max_obs <- max(unlist(lapply(seq_len(n_obs), function(i) {
    col <- utils::tail(colnames(s1)[which(s1[i, ] > 0)], 1)
    as.numeric(gsub("[a-zA-Z]_*", "", col))
  })), na.rm = TRUE)
  #* `Min non-zero bin`
  min_obs <- min(unlist(lapply(seq_len(n_obs), function(i) {
    col <- colnames(s1)[which(s1[i, ] > 0)][1]
    as.numeric(gsub("[a-zA-Z]_*", "", col))
  })), na.rm = TRUE)
  #* `Update bivariate pareto prior with sufficient statistics`
  location_u_prime <- max(c(max_obs, priors$location_u[1]))
  location_l_prime <- min(c(min_obs, priors$location_l[1]))
  scale_prime <- priors$scale[1] + n_obs
  #* `Define bivariate support if it is missing`
  #* `this will require some thought since there are two directions.`
  #* first problem is that qpareto requires the parameters to be > 0,
  #* but the lower boundary can be negative, or could be something like 1
  #* with a tail that becomes negative. I guess changing the center is the
  #* way to account for those potential problems.
  if (is.null(support)) {
    (quantiles_u <- qpareto(c(0.0001, 0.9999), scale_prime, abs(location_u_prime)))
    (quantiles_l <- qpareto(c(0.0001, 0.9999), scale_prime, abs(location_l_prime)))
    support_l <- seq(quantiles_l[1], quantiles_l[2], length.out = 10000)
    support_u <- seq(quantiles_u[1], quantiles_u[2], length.out = 10000)

    if (location_l_prime < 0) {
      quantiles_l <- -1 * rev(quantiles_l)
      support_l <- seq(quantiles_l[1], quantiles_l[2], length.out = 10000)
    }
    if (location_u_prime < 0) {
      quantiles_u <- -1 * rev(quantiles_u)
      support_u <- seq(quantiles_u[1], quantiles_u[2], length.out = 10000)
    }

    if (calculatingSupport) {
      return(list("A" = quantiles_l, "B" = quantiles_u))
    }
  } else {
    support_l <- support$A
    support_u <- support$B
  }
  #* `Make Posterior Draws`
  out$posteriorDraws <- .conj_cond_inv_rpareto(
    10000, location_l_prime, location_u_prime,
    scale_prime
  )
  #* `posterior`
  #* this also needs to handle the possibility of negative locations
  if (location_l_prime < 0) {
    dens_l <- extraDistr::dpareto(-1 * support_l, scale_prime, abs(location_l_prime))
  } else {
    dens_l <- extraDistr::dpareto(support_l, scale_prime, location_l_prime)
  }

  if (location_u_prime < 0) {
    dens_u <- extraDistr::dpareto(-1 * support_u, scale_prime, abs(location_u_prime))
  } else {
    dens_u <- extraDistr::dpareto(support_u, scale_prime, location_u_prime)
  }

  pdf_l <- dens_l / sum(dens_l)
  pdf_u <- dens_u / sum(dens_u)
  out$pdf <- list("A" = pdf_l, "B" = pdf_u)

  hde_l <- location_l_prime
  hde_u <- location_u_prime

  if (location_l_prime < 0) {
    hdi_l <- -1 * rev(extraDistr::qpareto(
      c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
      scale_prime, abs(location_l_prime)
    ))
  } else {
    hdi_l <- extraDistr::qpareto(
      c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
      scale_prime, location_l_prime
    )
  }
  if (location_u_prime < 0) {
    hdi_u <- -1 * rev(extraDistr::qpareto(
      c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
      scale_prime, abs(location_u_prime)
    ))
  } else {
    hdi_u <- extraDistr::qpareto(
      c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
      scale_prime, location_u_prime
    )
  }

  #* `Store summary`
  out$summary <- data.frame(
    HDE_1 = c(hde_l, hde_u),
    HDI_1_low = c(hdi_l[1], hdi_u[1]),
    HDI_1_high = c(hdi_l[2], hdi_u[2]),
    param = c("A", "B")
  )
  out$posterior <- list(
    "scale" = scale_prime, "location_l" = location_l_prime,
    "location_u" = location_u_prime
  )
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = c(support_l, support_u),
      "prob" = c(pdf_l, pdf_u),
      "param" = rep(c("A", "B"), each = length(support_u)),
      "sample" = rep("Sample 1", 2 * length(support_u))
    )
  }
  return(out)
}

#' @description
#' Internal function for calculating the pareto distribution of the upper boundary of a uniform
#' distribution represented by multi value traits.
#' @param s1 A data.frame or matrix of multi value traits.
#' @examples
#' s1 <- mvSim(
#'   dists = list(runif = list(min = 0, max = 150)),
#'   n_samples = 10,
#'   counts = 1000,
#'   min_bin = 1,
#'   max_bin = 180,
#'   wide = TRUE
#' )
#' out <- .conj_uniform_mv(s1, cred.int.level = 0.95)
#' lapply(out, head)
#' @importFrom utils tail
#'
#' @keywords internal
#' @noRd
.conj_uniform_mv <- function(s1 = NULL, priors = NULL,
                             plot = FALSE, support = NULL, cred.int.level = NULL,
                             calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(scale = 0.5, location = 0.5)
  }
  #* `Reorder columns if they are not in the numeric order`
  histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
  bins_order <- sort(histColsBin, index.return = TRUE)$ix
  s1 <- s1[, bins_order]
  #* `Calculate Sufficient Statistics`
  #* `N observations`
  n_obs <- nrow(s1)
  #* `Max non-zero bin`
  max_obs <- max(unlist(lapply(seq_len(n_obs), function(i) {
    col <- utils::tail(colnames(s1)[which(s1[i, ] > 0)], 1)
    as.numeric(gsub("[a-zA-Z]_*", "", col))
  })), na.rm = TRUE)
  #* `Update pareto prior with sufficient statistics`
  scale_prime <- priors$scale + n_obs
  location_prime <- max(c(max_obs, priors$location), na.rm = TRUE)
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qpareto(c(0.0001, 0.9999), scale_prime, location_prime)
    return(quantiles)
  }
  #* `Make Posterior Draws`
  out$posteriorDraws <- extraDistr::rpareto(10000, scale_prime, location_prime)
  #* `posterior`
  dens1 <- extraDistr::dpareto(support, scale_prime, location_prime)
  pdf1 <- dens1 / sum(dens1)
  out$pdf <- pdf1
  # hde of location is calculated off of the posterior draws
  hde1 <- mean(as.numeric(hdi(out$posteriorDraws, ci = 0.01)[c("CI_low", "CI_high")]))
  # mode is location
  # mean is defined if scale > 1: scale_prime * location_prime / scale_prime - 1
  # median is location x root scale of 2
  hdi1 <- extraDistr::qpareto(
    c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    scale_prime, location_prime
  )
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior <- list("scale" = scale_prime, "location" = location_prime)
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' @description
#' Internal function for calculating the pareto distribution of the upper boundary of a uniform
#' distribution represented by single value traits.
#' @param s1 A vector of numerics drawn from a uniform distribution.
#' @examples
#' out <- .conj_uniform_sv(
#'   s1 = runif(10, 0, 100), cred.int.level = 0.95,
#'   plot = FALSE
#' )
#' lapply(out, head)
#' @keywords internal
#' @noRd
.conj_uniform_sv <- function(s1 = NULL, priors = NULL,
                             plot = FALSE, support = NULL, cred.int.level = NULL,
                             calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(scale = 0.5, location = 0.5)
  }
  #* `Update pareto prior with sufficient statistics`
  scale_prime <- priors$scale + length(s1)
  location_prime <- max(c(s1, priors$location), na.rm = TRUE)
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qpareto(c(0.0001, 0.9999), scale_prime, location_prime)
    return(quantiles)
  }
  #* `Make Posterior Draws`
  out$posteriorDraws <- extraDistr::rpareto(10000, scale_prime, location_prime)
  #* `posterior`
  dens1 <- extraDistr::dpareto(support, scale_prime, location_prime)
  pdf1 <- dens1 / sum(dens1)
  out$pdf <- pdf1
  # hde of location is calculated off of the posterior draws
  hde1 <- mean(as.numeric(hdi(out$posteriorDraws, ci = 0.01)[c("CI_low", "CI_high")]))
  # mode is location
  # mean is defined if scale > 1: scale_prime * location_prime / scale_prime - 1
  # median is location x root scale of 2
  hdi1 <- extraDistr::qpareto(
    c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    scale_prime, location_prime
  )
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior <- list("scale" = scale_prime, "location" = location_prime)
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' Variance partitioning using Full Random Effects Models
#'
#' Variance partitioning for phenotypes (over time) using fully random effects models
#'
#' @param df Dataframe containing phenotypes and design variables, optionally over time.
#' @param des Design variables to partition variance for as a character vector.
#' @param phenotypes Phenotype column names (data is assumed to be in wide format)
#' as a character vector.
#' @param timeCol A column of the data that denotes time for longitudinal experiments.
#'   If left NULL (the default) then all data is assumed to be from one timepoint.
#' @param cor Logical, should a correlation plot be made? Defaults to TRUE.
#' @param returnData Logical, should the used to make plots be returned? Defaults to FALSE.
#' @param combine Logical, should plots be combined with patchwork?
#'  Defaults to TRUE, which works well when there is a single timepoint being used.
#' @param markSingular Logical, should singular fits be marked in the variance explained plot?
#'  This is FALSE by default but it is good practice to check with TRUE in some situations.
#'   If TRUE this will add white markings to the plot where models had singular fits,
#'    which is the most common problem with this type of model.
#' @param time If the data contains multiple timepoints then which should be used?
#'  This can be left NULL which will use the maximum time if \code{timeCol} is specified.
#'   If a single number is provided then that time value will be used.
#'    Multiple numbers will include those timepoints.
#'     The string "all" will include all timepoints.
#' @param ... Additional arguments passed to \code{lme4::lmer}.
#'
#' @import lme4
#' @import ggplot2
#' @importFrom scales percent_format
#' @importFrom stats as.formula na.omit
#' @import patchwork
#'
#' @return Returns either a plot (if returnData=FALSE) or a list with a plot and
#' data/a list of dataframes (depending on returnData and cor).
#'
#' @examples
#'
#'
#' library(data.table)
#' set.seed(456)
#' df <- data.frame(
#'   genotype = rep(c("g1", "g2"), each = 10),
#'   treatment = rep(c("C", "T"), times = 10),
#'   time = rep(c(1:5), times = 2),
#'   pheno1 = rnorm(20, 10, 1),
#'   pheno2 = sort(rnorm(20, 5, 1)),
#'   pheno3 = sort(runif(20))
#' )
#' out <- frem(df, des = "genotype", phenotypes = c("pheno1", "pheno2", "pheno3"), returnData = TRUE)
#' lapply(out, class)
#' frem(df,
#'   des = c("genotype", "treatment"), phenotypes = c("pheno1", "pheno2", "pheno3"),
#'   cor = FALSE
#' )
#' frem(df,
#'   des = "genotype", phenotypes = c("pheno1", "pheno2", "pheno3"),
#'   combine = FALSE, timeCol = "time", time = "all"
#' )
#' frem(df,
#'   des = "genotype", phenotypes = c("pheno1", "pheno2", "pheno3"),
#'   combine = TRUE, timeCol = "time", time = 1
#' )
#' frem(df,
#'   des = "genotype", phenotypes = c("pheno1", "pheno2", "pheno3"),
#'   cor = FALSE, timeCol = "time", time = 3:5, markSingular = TRUE
#' )
#'
#' @export

frem <- function(df, des, phenotypes, timeCol = NULL, cor = TRUE, returnData = FALSE, combine = TRUE,
                 markSingular = FALSE, time = NULL, ...) {
  dummyX <- FALSE
  if (is.null(timeCol)) {
    timeCol <- "dummy_x_axis"
    df[[timeCol]] <- 1
    dummyX <- TRUE
  }
  #* `Make formulas`
  ext <- FALSE
  if (length(des) == 2) {
    ind_fmla <- paste0("(1|", des[1], ")+(1|", des[2], ")+(1|", des[1], ":", des[2], ")")
  } else {
    ind_fmla <- paste(paste0("(1|", des, ")"), collapse = "+")
    ext <- TRUE
  }
  #* `Find time and subset data`
  if (is.null(time)) {
    dat <- na.omit(df[df[[timeCol]] == max(df[[timeCol]]), c(des, phenotypes, timeCol)])
    LONGITUDINAL <- FALSE
  } else if (is.numeric(time) && length(time) == 1) {
    dat <- na.omit(df[df[[timeCol]] == time, c(des, phenotypes, timeCol)])
    LONGITUDINAL <- FALSE
  } else if (is.numeric(time) && length(time) > 1) {
    LONGITUDINAL <- TRUE
    dat <- na.omit(df[df[[timeCol]] %in% time, c(des, phenotypes, timeCol)])
  } else if (time == "all") {
    LONGITUDINAL <- TRUE
    dat <- na.omit(df[, c(des, phenotypes, timeCol)])
  }

  #* `Partition Variance`

  H2 <- .partitionVarianceFrem(dat, timeCol, phenotypes, ind_fmla, ext, des, ...)

  if (!ext) {
    colnames(H2) <- c(des[1], des[2], "Interaction", "Unexplained", timeCol, "singular", "Phenotypes")
  } else {
    colnames(H2) <- c(des, "Unexplained", timeCol, "singular", "Phenotypes")
  }
  ordering <- H2[H2[[timeCol]] == max(H2[[timeCol]]), ]
  H2$Phenotypes <- ordered(H2$Phenotypes, levels = ordering$Phenotypes[order(ordering$Unexplained)])
  h2_melt <- data.frame(data.table::melt(as.data.table(H2), id = c("Phenotypes", "singular", timeCol)))

  if (!ext) {
    h2_melt$variable <- ordered(h2_melt$variable,
      levels = c("Unexplained", des[1], des[2], "Interaction")
    )
  } else {
    h2_melt$variable <- ordered(h2_melt$variable,
      levels = c("Unexplained", des)
    )
  }
  anova_dat <- h2_melt

  #* `Plot Variance`

  plotHelperOutputs <- .fremPlotHelper(
    LONGITUDINAL, anova_dat, markSingular, dummyX, timeCol, dat, phenotypes,
    cor, combine
  )
  plot <- plotHelperOutputs[["plot"]]
  x <- plotHelperOutputs[["x"]]
  cor <- plotHelperOutputs[["cor"]]
  out <- .fremCollectOutputs(returnData, cor, H2, x, plot)
  return(out)
}

#' helper function to plot FREM results
#' @keywords internal
#' @noRd

.fremCollectOutputs <- function(returnData, cor, H2, x, plot) {
  if (returnData) {
    if (cor) {
      out_data <- list("variance" = H2, "cor" = x)
    } else {
      out_data <- H2
    }
    out <- list("plot" = plot, "data" = out_data)
  } else {
    out <- plot
  }
  return(out)
}


#' helper function to plot FREM results
#' @keywords internal
#' @noRd

.fremPlotHelper <- function(LONGITUDINAL, anova_dat, markSingular, dummyX, timeCol, dat, phenotypes,
                            cor, combine) {
  x <- NULL
  if (!LONGITUDINAL) {
    p <- ggplot2::ggplot(data = anova_dat) +
      ggplot2::geom_col(ggplot2::aes(y = .data$Phenotypes, x = .data$value, fill = .data$variable)) +
      ggplot2::xlab("Variance Explained") +
      ggplot2::guides(fill = ggplot2::guide_legend(title = "", reverse = TRUE)) +
      ggplot2::theme_minimal() +
      ggplot2::scale_x_continuous(expand = c(0, 0, 0, 0), labels = scales::percent_format()) +
      ggplot2::theme(
        axis.text = ggplot2::element_text(size = 14),
        axis.title.y = ggplot2::element_blank()
      ) +
      ggplot2::theme(axis.ticks.length = ggplot2::unit(0.2, "cm")) +
      ggplot2::theme(legend.position = "bottom")

    if (markSingular) {
      p <- p + ggplot2::geom_point(
        data = anova_dat[as.logical(anova_dat$singular) & anova_dat$variable == "Unexplained", ],
        aes(x = 0.99, y = .data$Phenotypes), color = "white", shape = 0
      )
    }
    if (dummyX) {
      p <- p + ggplot2::theme(axis.title.x.bottom = ggplot2::element_blank())
    }
  } else {
    p <- ggplot(data = anova_dat, aes(x = .data[[timeCol]], y = .data$value, fill = .data$variable)) +
      ggplot2::geom_area() +
      ggplot2::facet_wrap(~ .data$Phenotypes) +
      ggplot2::ylab("Variance Explained") +
      ggplot2::guides(fill = ggplot2::guide_legend(title = "", reverse = TRUE)) +
      ggplot2::scale_y_continuous(expand = c(0, 0, 0, 0), labels = scales::percent_format()) +
      ggplot2::scale_x_continuous(expand = c(0, 0, 0, 0), labels = ~ round(., 1)) +
      ggplot2::theme_minimal() +
      ggplot2::theme(
        axis.text.y = ggplot2::element_text(size = 10),
        axis.title.y = ggplot2::element_blank(),
        legend.position = "bottom"
      )
    if (markSingular) {
      p <- p + ggplot2::geom_vline(
        data = anova_dat[anova_dat$variable == "Unexplained" & as.logical(anova_dat$singular), ],
        ggplot2::aes(xintercept = .data[[timeCol]]), color = "white", linetype = 5, linewidth = 0.1
      )
    }
    if (dummyX) {
      p <- p + ggplot2::theme(axis.title.x.bottom = ggplot2::element_blank())
    }
  }

  #* `Get Correlations`
  if (length(phenotypes) == 1) {
    cor <- FALSE
  }
  if (cor) {
    corr <- cor(apply(dat[, (colnames(dat) %in% phenotypes)], 2, as.numeric),
      use = "complete.obs", method = "spearman"
    )
    unexp <- anova_dat[anova_dat$variable == "Unexplained" &
                         anova_dat[[timeCol]] == max(anova_dat[[timeCol]]), ]
    corr <- corr[
      as.character(unexp$Phenotypes[order(unexp$value)]),
      as.character(unexp$Phenotypes[order(unexp$value)])
    ]
    x <- na.omit(
      as.data.frame(
        suppressWarnings(data.table::melt(as.data.table(corr), variable.name = "Var2"))
      )
    )
    x$Var1 <- rep(rownames(corr), length.out = nrow(x))

    x$Var1 <- ordered(x$Var1, levels = unexp$Phenotypes[order(unexp$value)])
    x$Var2 <- ordered(x$Var2, levels = unexp$Phenotypes[order(unexp$value)])

    p2 <- ggplot2::ggplot(x, ggplot2::aes(.data$Var1, .data$Var2)) +
      ggplot2::geom_point(ggplot2::aes(color = .data$value), size = 4) +
      ggplot2::scale_color_gradient2(
        limits = c(-1, 1),
        midpoint = 0
      ) +
      ggplot2::theme_minimal() +
      ggplot2::guides(color = ggplot2::guide_colourbar(barwidth = 15, title = NULL)) +
      ggplot2::labs(x = "Correlations", y = "") +
      ggplot2::theme(
        legend.position = "bottom",
        axis.text.x.bottom = ggplot2::element_text(angle = 90, hjust = 1)
      )
    if (combine) {
      p2 <- p2 + ggplot2::theme(axis.text.y.left = ggplot2::element_blank())
    }
  }

  if (cor) {
    if (combine) {
      plot <- p + p2
    } else {
      plot <- list(p, p2)
    }
  } else {
    plot <- p
  }
  return(list("plot" = plot, "x" = x, "cor" = cor))
}

#' helper function to run models in frem
#' @keywords internal
#' @noRd

.partitionVarianceFrem <- function(dat, timeCol, phenotypes, ind_fmla, ext, des, ...) {
  H2 <- data.frame(do.call(rbind, lapply(sort(unique(dat[[timeCol]])), function(tm) {
    sub <- dat[dat[[timeCol]] == tm, ]
    do.call(rbind, lapply(phenotypes, function(e) {
      fmla <- as.formula(paste0("as.numeric(", e, ") ~ ", ind_fmla))
      model <- suppressMessages(lme4::lmer(fmla, data = sub, ...))
      if (length(model@optinfo$conv$lme4) >= 1) {
        singular <- any(grepl("isSingular", model@optinfo$conv$lme4$messages))
      } else {
        singular <- FALSE
      }
      re <- lme4::VarCorr(model)
      res <- attr(lme4::VarCorr(model), "sc")^2

      if (!ext) {
        interaction.var <- as.numeric(attr(re[[which(grepl(":", names(re)))]], "stddev"))^2
        des1.var <- as.numeric(attr(re[[des[1]]], "stddev"))^2
        des2.var <- as.numeric(attr(re[[des[2]]], "stddev"))^2

        tot.var <- sum(as.numeric(re), res)
        unexp <- 1 - sum(as.numeric(re)) / sum(as.numeric(re), res)

        h2 <- c(
          (des1.var / tot.var),
          (des2.var / tot.var),
          (interaction.var / tot.var),
          unexp,
          tm,
          singular
        )
      } else {
        var <- lapply(des, function(i) {
          as.numeric(attr(re[[i]], "stddev"))^2
        })

        tot.var <- sum(as.numeric(re), res)
        unexp <- 1 - sum(as.numeric(re)) / sum(as.numeric(re), res)

        h2 <- c(unlist(var) / tot.var, unexp, tm, singular)
      }
      return(h2)
    }))
  })))
  H2$Phenotypes <- rep(phenotypes, length.out = nrow(H2))
  return(H2)
}

#' @description
#' Internal function for calculating \alpha and \beta of a distribution represented by multi value
#' traits.
#' @param s1 A data.frame or matrix of multi value traits. The column names should include a number
#' between 0.0001 and 0.9999 representing the "bin".
#' @examples
#'
#' mv_beta <- mvSim(
#'   dists = list(
#'     rbeta = list(shape1 = 5, shape2 = 8),
#'   ),
#'   n_samples = c(30)
#' )
#' .conj_beta_mv(
#'   s1 = mv_beta[1:30, -1], priors = list(a = c(0.5), b = c(0.5)),
#'   cred.int.level = 0.9,
#'   plot = TRUE
#' )
#'
#' @keywords internal
#' @noRd
.conj_beta_mv <- function(s1 = NULL, priors = NULL,
                          plot = FALSE, support = NULL, cred.int.level = NULL,
                          calculatingSupport = FALSE) {
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(a = 0.5, b = 0.5)
  }
  #* `Define dense Support`
  if (is.null(support) && calculatingSupport) {
    return(c(0.0001, 0.9999))
  }
  out <- list()
  #* `Reorder columns if they are not in the numeric order`
  histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
  if (any(histColsBin > 1) || any(histColsBin < 0)) {
    stop("Beta Distribution is only defined on [0,1]")
  }
  bins_order <- sort(histColsBin, index.return = TRUE)$ix
  s1 <- s1[, bins_order]

  #* `Turn matrix into a vector`
  X1 <- rep(histColsBin[bins_order], as.numeric(round(colSums(s1))))

  #* `get parameters for s1 using method of moments``
  #* y ~ Beta(\alpha, \beta)
  #* \alpha ~ \bar{y}( ( (\bar{y} * (1-\bar{y}))/\bar(var) )-1 )
  #* \beta ~ (1-\bar{y})( ( (\bar{y} * (1-\bar{y}))/\bar(var) )-1 )
  mu1 <- mean(X1) #' \bar{y}
  nu1 <- var(X1) / (nrow(s1) - 1) #' \bar{var} the unbiased sample variance
  alpha1 <- mu1 * ((mu1 * (1 - mu1)) / (nu1) - 1)
  beta1 <- (1 - mu1) * ((mu1 * (1 - mu1)) / (nu1) - 1)

  #* `Add priors`
  a1_prime <- alpha1 + priors$a[1]
  b1_prime <- beta1 + priors$b[1]

  #* `calculate density`
  dens1 <- dbeta(support, a1_prime, b1_prime)
  pdf1 <- dens1 / sum(dens1)

  #* `calculate highest density interval`
  hdi1 <- qbeta(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), a1_prime, b1_prime)

  #* `calculate highest density estimate`
  hde1 <- .betaHDE(a1_prime, b1_prime)

  #* `save summary and parameters`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior$a <- a1_prime
  out$posterior$b <- b1_prime
  #* `Make Posterior Draws`
  out$posteriorDraws <- rbeta(10000, a1_prime, b1_prime)
  out$pdf <- pdf1
  #* `keep data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support, "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }

  return(out)
}



#' @description
#' Internal function for calculating \alpha and \beta of a distribution represented by multi value
#' traits.
#' @param s1 A vector of numerics drawn from a beta distribution.
#' @examples
#' .conj_beta_sv(
#'   s1 = rbeta(100, 5, 10),
#'   priors = list(a = c(0.5, 0.5), b = c(0.5, 0.5)),
#'   cred.int.level = 0.9,
#'   plot = FALSE
#' )
#' @keywords internal
#' @noRd
.conj_beta_sv <- function(s1 = NULL, priors = NULL,
                          plot = FALSE, support = NULL, cred.int.level = NULL,
                          calculatingSupport = FALSE) {
  if (any(c(s1) > 1) || any(c(s1) < 0)) {
    stop("Beta Distribution is only defined on [0,1]")
  }
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(a = 0.5, b = 0.5)
  }
  #* `Define dense Support`
  if (is.null(support) && calculatingSupport) {
    return(c(0.0001, 0.9999))
  }
  out <- list()

  #* `get parameters for s1 using method of moments``
  #* y ~ Beta(\alpha, \beta)
  #* \alpha ~ \bar{y}( ( (\bar{y} * (1-\bar{y}))/\bar(var) )-1 )
  #* \beta ~ (1-\bar{y})( ( (\bar{y} * (1-\bar{y}))/\bar(var) )-1 )
  mu1 <- mean(s1) #' \bar{y}
  nu1 <- var(s1) / (length(s1) - 1) #' \bar{var} the unbiased sample variance
  alpha1 <- mu1 * ((mu1 * (1 - mu1)) / (nu1) - 1)
  beta1 <- (1 - mu1) * ((mu1 * (1 - mu1)) / (nu1) - 1)

  #* `Add priors in`
  a1_prime <- priors$a[1] + alpha1
  b1_prime <- priors$b[1] + beta1

  #* `calculate density over support``
  dens1 <- dbeta(support, a1_prime, b1_prime)
  pdf1 <- dens1 / sum(dens1)

  #* `calculate highest density interval`
  hdi1 <- qbeta(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), a1_prime, b1_prime)

  #* `calculate highest density estimate`
  hde1 <- .betaHDE(a1_prime, b1_prime)

  #* `save summary and parameters`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior$a <- a1_prime
  out$posterior$b <- b1_prime
  #* `Make Posterior Draws`
  out$posteriorDraws <- rbeta(10000, a1_prime, b1_prime)
  out$pdf <- pdf1
  #* `keep data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support, "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' @description
#' Internal function for calculating the HDE of a beta distribution
#' @param alpha alpha parameter
#' @param beta beta parameter
#' @examples
#' .betaHDE(1, 2)
#' .betaHDE(2, 1)
#' .betaHDE(10, 10)
#' @keywords internal
#' @noRd

.betaHDE <- function(alpha, beta) {
  if (alpha <= 1 && beta > 1) {
    hde <- 0
  } else if (alpha > 1 && beta <= 1) {
    hde <- 1
  } else {
    hde <- (alpha - 1) / (alpha + beta - 2)
  }
  return(hde)
}

#' Read in plantCV csv output in wide or long format
#'
#' @param filepath Path to csv file of plantCV output.
#' @param mode NULL (the default) or one of "wide" or "long", partial string matching is supported.
#'    This controls whether data is \strong{returned} in long or wide format. If left NULL then
#'    the output format will be the same as the input format.
#' @param traitCol Column with phenotype names, defaults to "trait".
#'   This should generally not need to be changed from the default. This,
#'   labelCol, and valueCol are used to determine if data are in long format in their
#'   raw state (the csv file itself).
#' @param labelCol Column with phenotype labels (units), defaults to "label".
#'   This should generally not need to be changed from the default.
#'   This is used with traitCol when \code{mode="wide"} to identify
#'   unique traits since some may be ambiguous
#' (ellipseCenter.x vs ellipseCenter.y, bins of histograms, etc)
#' @param valueCol Column with phenotype values, defaults to "value".
#'   This should generally not need to be changed from the default.
#' @param reader The function to use to read in data,
#'   defaults to NULL in which case \code{data.table::fread} is used if filters are in place
#'   and \code{read.csv} is used otherwise.
#'   Note that if you use \code{read.csv} with filters in place then you will need to specify
#'   \code{header=FALSE} so that the piped output from awk is read correctly.
#'   If fread is too slow for your needs then \code{vroom::vroom()} may be useful.
#' @param filters If a very large pcv output file is read then it may be desireable
#'   to subset it before reading it into R, either for ease of use or because of RAM limitations.
#'   The filter argument works with "COLUMN in VALUES" syntax. This can either be a character vector
#'   or a list of character vectors. In these vectors there needs to be a column name,
#'   one of " in ", " is ", or " = " to match the string exactly, or "contains"
#'   to match with awk style regex, then a set of comma delimited values to filter
#'   that column for (see examples). Note that this and awk both use awk through \code{pipe()}.
#'   This functionality will not work on a windows system.
#' @param awk As an alternative to filters a direct call to awk can be supplied here,
#'   in which case that call will be used through \code{pipe()}.
#' @param ... Other arguments passed to the reader function.
#'   In the case of 'fread' there are several defaults provided already
#'   which can be overwritten with these extra arguments.
#'
#' @details
#' In plantCV version 4 the single value traits are returned in wide format from \code{json2csv}
#' and the multi value traits are returned in long format. Briefly plantCV data was returned as one
#' long table which sparked the emphasis in this function on reading data quickly and parsing it
#' outside of R. With the current plantCV output these options are largely unnecessary.
#' When data is read in using read.pcv the traitCol, valueCol, and labelCol arguments are checked
#' to determine if the data is in long format. This is done to keep compatibility with interim
#' versions of plantcv output where all outputs were in a single long format file.
#'
#' With the current implementation and plantcv output you can read wide or long format files into
#' wide or long format in R. Keep in mind that the 'mode' argument controls the format that will be
#' returned in R, not the format that the data saved as in your csv file.
#'
#' @keywords read.csv pcv4
#' @return Returns a data.frame in wide or long format.
#' @importFrom stats as.formula
#' @import data.table
#' @examples
#' \donttest{
#' mv <- paste0(
#'   "https://media.githubusercontent.com/media/joshqsumner/",
#'   "pcvrTestData/main/pcv4-multi-value-traits.csv"
#' )
#' sv <- paste0(
#'   "https://raw.githubusercontent.com/joshqsumner/",
#'   "pcvrTestData/main/pcv4-single-value-traits.csv"
#' )
#'
#' w2w <- read.pcv(sv, mode = "wide", reader = "fread")
#' dim(w2w)
#'
#' w2l <- read.pcv(sv, mode = "long", reader = "fread")
#' dim(w2l)
#'
#' l2w <- read.pcv(mv, mode = "wide", reader = "fread")
#' dim(l2w)
#'
#' l2l <- read.pcv(mv, mode = "long", reader = "fread")
#' dim(l2l)
#' }
#'
#' @export

read.pcv <- function(filepath, mode = NULL,
                     traitCol = "trait", labelCol = "label", valueCol = "value",
                     reader = NULL, filters = NULL, awk = NULL, ...) {
  if (is.null(filters) && is.null(awk)) {
    if (is.null(reader)) {
      reader <- "read.csv"
    }
    if (reader != "fread") {
      readingFunction <- match.fun(reader)
    } else {
      readingFunction <- data.table::fread
    }
    df1 <- as.data.frame(readingFunction(filepath, ...))
  } else {
    if (is.null(reader)) {
      reader <- "fread"
    }
    df1 <- pcv.sub.read(inputFile = filepath, filters = filters, reader = reader, awk = awk, ...)
    if (nrow(df1) < 1) {
      stop(paste0(
        "0 Rows returned using awk statement:\n", awkHelper(filepath, filters),
        "\nMost common issues are misspellings or not including a column name and affector."
      ))
    }
  }
  #* `check original data format`
  checkDataStateRes <- .readpcvCheckDataState(df1, traitCol, valueCol, labelCol, mode)
  startsLong <- checkDataStateRes[["startsLong"]]
  outputMode <- checkDataStateRes[["outputMode"]]
  #* `if data is long and mode is wide`
  out <- .readpcvReshapeData(df1, outputMode, startsLong, traitCol, valueCol, labelCol)
  colnames(out) <- gsub("/", ".over.", colnames(out))
  colnames(out) <- gsub("\\'", "", colnames(out))
  return(out)
}


#' @description
#' Internal function for checking input data to
#' @param priors priors as a list
#' @keywords internal
#' @noRd

.readpcvCheckDataState <- function(df1, traitCol, valueCol, labelCol, mode) {
  if (all(c(traitCol, valueCol, labelCol) %in% colnames(df1))) {
    startsLong <- TRUE
  } else if (!any(c(traitCol, valueCol, labelCol) %in% colnames(df1))) {
    startsLong <- FALSE
  } else {
    found <- c(
      "traitCol",
      "valueCol",
      "labelCol"
    )[which(c(traitCol, valueCol, labelCol) %in% colnames(df1))]
    warning(paste0(
      paste(found, collapse = ", "),
      " found in column names of data but either all or none of traitCol,",
      " valueCol, and labelCol are expected. Data will be returned as is."
    ))
    startsLong <- FALSE
  }

  if (is.null(mode)) {
    if (startsLong) {
      outputMode <- "long"
    } else {
      outputMode <- "wide"
    }
  } else {
    outputMode <- match.arg(mode, c("wide", "long"))
  }
  return(list(
    "startsLong" = startsLong,
    "outputMode" = outputMode
  ))
}

#' @description
#' Internal function for reshaping data in read.pcv
#' @param priors priors as a list
#' @keywords internal
#' @noRd

.readpcvReshapeData <- function(df1, outputMode, startsLong, traitCol, valueCol, labelCol) {
  if (startsLong) {
    #* `if data is long and mode is wide`
    if (outputMode == "wide") {
      long <- df1
      if (substr(colnames(long)[1], 1, 1) == "X" && length(unique(long[[1]])) == nrow(long)) {
        long <- long[, -1]
      }
      long <- long[!is.na(long[[valueCol]]), ]
      long[[labelCol]] <- ifelse(is.na(long[[labelCol]]), "none", long[[labelCol]])
      wide <- as.data.frame(data.table::dcast(data.table::as.data.table(long),
        as.formula(paste0("... ~ ", traitCol, "+", labelCol)),
        value.var = valueCol, sep = "."
      ))
      colnames(wide) <- sub(".none$", "", colnames(wide))
      if (any(grepl("hist|frequencies", colnames(wide)))) { # reorder the MV traits by their bins
        #* get a list of the unique non-numeric parts
        histCols <- colnames(wide)[grepl("hist|frequencies", colnames(wide))]
        uniqueMvTraits <- unique(gsub("[.]+$", "", gsub("[0-9]+", "", histCols)))
        #* for each unique non-numeric part, sort the names
        mvColsReordered <- unlist(lapply(uniqueMvTraits, function(umt) {
          iterCols <- histCols[grepl(umt, histCols)]
          iterColsNumeric <- as.numeric(gsub(paste0(umt, "."), "", iterCols))
          bins_order <- sort(iterColsNumeric, index.return = TRUE)$ix
          iterCols[bins_order]
        }))
        #* combine the histCols and the other columns, in the new order.
        sv_and_meta_cols <- colnames(wide)[!grepl("hist|frequencies", colnames(wide))]
        wide <- wide[, c(sv_and_meta_cols, mvColsReordered)]
      }
      out <- wide

      #* `if data is long and mode is long`
    } else if (outputMode == "long") {
      out <- df1
      out[[traitCol]] <- gsub("/", ".over.", out[[traitCol]])
      out[[traitCol]] <- gsub("\\'", "", out[[traitCol]])
      #* `if data is wide and mode is wide (single value traits only)`
    }
  } else {
    if (outputMode == "wide") {
      out <- df1
      #* `if data is wide and mode is long (single value traits only)`
    } else if (outputMode == "long") {
      #* ***** `find phenotype columns as section of numerics at end of data`
      sequence <- seq(ncol(df1), 1, -1)
      numeric_cols <- as.numeric(which(unlist(lapply(df1, is.numeric))))
      pheno_position_in_seq <- which(unlist(lapply(seq_along(numeric_cols), function(i) {
        sequence[i] == rev(numeric_cols)[i]
      })))
      pheno_cols <- rev(sequence[pheno_position_in_seq])
      #* ***** `melt data`
      #* note this will warn about numeric vs integer
      #* so I am suppressing that since it should always be fine to do that.
      out <- suppressWarnings(
        as.data.frame(
          data.table::melt(
            data.table::as.data.table(df1),
            measure.vars = pheno_cols, variable.name = traitCol,
            value.name = valueCol
          )
        )
      )
    }
  }
  return(out)
}

#' Function to visualize common \code{nlme::nlme} growth models.
#'
#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
#' (and similar models made through other means)
#'  can be visualized easily using this function. This will generally be called by \code{growthPlot}.
#'
#' @param fit A model fit returned by \code{fitGrowth} with type="nlme".
#' @param form A formula similar to that in \code{growthSS} inputs (or the \code{pcvrForm} part of the
#' output) specifying the outcome, predictor, and grouping structure of the data as
#' \code{outcome ~ predictor|individual/group}
#' @param df A dataframe to use in plotting observed growth curves on top of the model.
#' This must be supplied for nlme models.
#' @param groups An optional set of groups to keep in the plot.
#' Defaults to NULL in which case all groups in the model are plotted.
#' @param timeRange An optional range of times to use. This can be used to view predictions for
#' future data if the avaiable data has not reached some point (such as asymptotic size).
#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
#' @param groupFill logical, should groups have different colors? Defaults to FALSE. If TRUE then
#' viridis colormaps are used in the order of virMaps.
#' @param virMaps order of viridis maps to use. Will be recycled to necessary length.
#' Defaults to "plasma", but will generally be informed by growthPlot's default.
#' @keywords growth-curve
#' @importFrom methods is
#' @import ggplot2
#' @importFrom stats predict update residuals
#' @importFrom nlme nlme nlme.formula
#' @examples
#'
#' simdf <- growthSim("logistic",
#'   n = 10, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#'
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group, sigma = "none",
#'   df = simdf, start = NULL, type = "nlme"
#' )
#'
#' fit <- fitGrowth(ss)
#'
#' nlmePlot(fit, form = ss$pcvrForm, groups = NULL, df = ss$df, timeRange = NULL)
#' nlmePlot(fit, form = ss$pcvrForm, groups = "a", df = ss$df, timeRange = 1:10, groupFill = TRUE)
#'
#' @return Returns a ggplot showing an nlme model's credible
#' intervals and optionally the individual growth lines.
#'
#' @export
#'

nlmePlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE,
                     groupFill = FALSE, virMaps = c("plasma")) {
  #* `get needed information from formula`
  parsed_form <- .parsePcvrForm(form, df)
  y <- parsed_form$y
  x <- parsed_form$x
  individual <- parsed_form$individual
  if (individual == "dummyIndividual") {
    individual <- NULL
  }
  group <- parsed_form$group
  df <- parsed_form$data
  #* `filter by groups if groups != NULL`
  if (!is.null(groups)) {
    df <- df[df[[group]] %in% groups, ]
  }
  intVar <- paste0(group, individual)
  #* `make new data if timerange is not NULL`
  if (!is.null(timeRange)) {
    new_data <- do.call(rbind, lapply(unique(df[[intVar]]), function(g) {
      stats::setNames(data.frame(g, timeRange), c(intVar, x))
    }))
    new_data[[group]] <- gsub("[.].*", "", new_data[[intVar]])
    new_data[[individual]] <- gsub(".*[.]", "", new_data[[intVar]])
    df <- df[df[[x]] >= min(timeRange) & df[[x]] <= max(timeRange), ]
  } else {
    new_data <- df
  }

  preds <- new_data
  preds$trendline <- round(predict(fit, preds), 4)
  preds <- preds[!duplicated(preds$trendline), ]
  preds <- .add_sigma_bounds(preds, fit, x, group)

  #* `plot`

  #* `facetGroups`
  facet_layer <- NULL
  if (facetGroups) {
    facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
  }
  #* `groupFill`
  pal <- viridis::plasma(2, begin = 0.1, end = 0.9)
  virList <- lapply(seq_along(unique(df[[group]])), function(i) {
    pal
  })
  if (groupFill) {
    virList <- lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
      viridis::viridis(2, begin = 0.1, end = 0.9, option = pal)
    })
  }
  #* `layer for individual lines if formula was complete`
  individual_lines <- list()
  if (!is.null(individual)) {
    individual_lines <- ggplot2::geom_line(
      data = df, ggplot2::aes(
        x = .data[[x]], y = .data[[y]],
        group = interaction(
          .data[[individual]],
          .data[[group]]
        )
      ),
      linewidth = 0.25, color = "gray40"
    )
  }

  plot <- ggplot2::ggplot(preds, ggplot2::aes(x = .data[[x]], y = .data[["trendline"]])) +
    facet_layer +
    individual_lines +
    ggplot2::labs(x = x, y = y) +
    pcv_theme()

  for (g in seq_along(unique(preds[[group]]))) {
    iteration_group <- unique(preds[[group]])[g]
    sub <- preds[preds[[group]] == iteration_group, ]
    plot <- plot +
      ggplot2::geom_ribbon(
        data = sub, ggplot2::aes(
          ymin = .data[["sigma_ymin"]],
          ymax = .data[["sigma_ymax"]]
        ),
        fill = virList[[g]][1], alpha = 0.5
      ) +
      ggplot2::geom_line(data = sub, color = virList[[g]][2], linewidth = 0.75)
  }

  return(plot)
}

#' convenience function for calculating sigma upper and lower bounds
#' @keywords internal
#' @noRd
.add_sigma_bounds <- function(preds, fit, x, group) {
  res <- do.call(rbind, lapply(unique(preds[[group]]), function(grp) {
    varCoef <- as.numeric(fit$modelStruct$varStruct[grp])

    sub <- preds[preds[[group]] == grp, ]
    exes <- sub[[x]]

    if (methods::is(fit$modelStruct$varStruct, "varPower")) {
      out <- exes^(2 * varCoef)
    } else if (methods::is(fit$modelStruct$varStruct, "varExp")) {
      out <- exp(2 * varCoef * exes)
    } else if (methods::is(fit$modelStruct$varStruct, "varIdent")) {
      baseSigma <- fit$sigma
      varSummary <- summary(fit$modelStruct$varStruct)
      coefs <- data.frame(
        x = 1 / unique(attr(varSummary, "weight")),
        g = unique(attr(varSummary, "groups"))
      )
      out <- baseSigma * coefs[coefs$g == grp, "x"]
    }

    sub$sigma_ymax <- sub$trendline + 0.5 * out
    sub$sigma_ymin <- sub$trendline - 0.5 * out
    return(sub)
  }))

  return(res)
}

#' alias of nlmePlot for using lme models via class matching
#' @keywords internal
#' @noRd

lmePlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE,
                    groupFill = FALSE, virMaps = c("plasma")) {
  nlmePlot(fit, form, df, groups, timeRange, facetGroups, groupFill, virMaps)
}

#' Ease of use wrapper function for fitting various growth models specified by \link{growthSS}
#'
#' @param ss A list generated by \code{growthSS}.
#' @param ... Additional arguments passed to model fitting functions determined by \code{ss$type}.
#' For type = "nlme" these are passed to \code{nlme::nlmeControl}, not \code{nlme::nlme}.
#' Additional arguments are documented in \link{fitGrowthbrms}, \link{fitGrowthnlme},
#' \link{fitGrowthnls}, \link{fitGrowthnlrq}, \link{fitGrowthmgcvgam}, \link{fitGrowthsurvreg},
#' \link{fitGrowthflexsurv}.
#' @keywords Bayesian brms nlme nls nlrq
#' @return A fit model from the selected type.
#'
#' @examples
#'
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | group,
#'   df = simdf, type = "nls"
#' )
#' fitGrowth(ss)
#' ss <- growthSS(
#'   model = "gam", form = y ~ time | group,
#'   df = simdf, type = "nls"
#' )
#' fitGrowth(ss)
#'
#' @export

fitGrowth <- function(ss, ...) {
  if (ss$model == "gam") {
    suffix <- "gam"
  } else {
    suffix <- NULL
  }
  fit_function <- match.fun(paste0("fitGrowth", ss$type, suffix))
  fit <- fit_function(ss, ...)
  return(fit)
}

#' Ease of use brms wrapper function for fitting growth models specified by \code{growthSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{growthSS}.
#' @param iter A number of iterations to sample for each chain.
#' By default half this length is taken as warm-up for the MCMC algorithm.
#' This defaults to 2000.
#' @param cores A number of cores to run in parallel.
#' This defaults to 1 if the "mc.cores" option is not set.
#' Generally this is specified as one core per chain so that the model is fit in parallel.
#' @param chains A number of markov chains to use, this defaults to 4.
#' @param prior A \code{brmsprior} object if \code{growthSS} did not have priors specified.
#' If left NULL (the default) and ss does not contain priors then a warning is
#' issued but the model will still attempt to fit.
#' @param backend A backend for brms to use Stan through.
#'   This defaults to use "cmdstanr".
#' @param silent Passed to \code{brms::brm} to control verbosity.
#' This defaults to 0, the most verbose option so that messages and progress are printed.
#' With changes to \code{cmdstanr} and \code{brms} this may be removed, but the option
#' will be available through \code{...}. Note that this is likely to print lots of
#' messages during warmup iterations as the MCMC gets started.
#' @param ... Additional arguments passed to \code{brms::brm}.
#' @keywords Bayesian brms
#' @return A \code{brmsfit} object, see \code{?`brmsfit-class`} for details.
#' @export

fitGrowthbrms <- function(ss, iter = 2000, cores = getOption("mc.cores", 1), chains = 4, prior = NULL,
                          backend = "cmdstanr", silent = 0, ...) {
  if (!"prior" %in% names(ss) && is.null(prior)) {
    warning(
      paste0(
        "No prior was specified. Flat priors will be used, this is likely to cause problems in model ",
        "fitting and yield less accurate results. If you are fitting a gam then ignore this warning."
      )
    )
  } else if ("prior" %in% names(ss)) {
    prior <- ss$prior
  }
  fit <- brms::brm(
    formula = ss$formula, prior = prior, data = ss$df, family = ss$family,
    iter = iter, init = ss$initfun, cores = cores, chains = chains,
    backend = backend, silent = silent, ...
  )
  return(fit)
}

#' Ease of use nlme wrapper function for fitting growth models specified by \code{growthSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{growthSS}.
#' @param ... Additional arguments passed to \code{nlme::nlmeControl}.
#' @keywords nlme
#' @return An \code{nlme} object, see \code{?nlme} for details.
#' @importFrom nlme nlme
#' @export

fitGrowthnlme <- function(ss, ...) {
  fit <- do.call(nlme,
    args = list(
      model = ss[["formula"]][["model"]],
      data = quote(ss[["df"]]),
      fixed = ss[["formula"]][["fixed"]],
      random = ss[["formula"]][["random"]],
      groups = ss[["formula"]][["groups"]],
      weights = ss[["formula"]][["weights"]],
      correlation = ss[["formula"]][["cor_form"]],
      start = ss[["start"]],
      control = nlme::nlmeControl(returnObject = TRUE, ...)
    )
  )
  return(fit)
}

#' Ease of use lme wrapper function for fitting gams specified by \code{growthSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{growthSS}.
#' @param ... Additional arguments passed to \code{nlme::lmeControl}.
#' @keywords nlme gam
#' @return An \code{lme} object, see \code{?lme} for details.
#' @importFrom nlme lme
#' @export

fitGrowthnlmegam <- function(ss, ...) {
  fit <- do.call(lme,
    args = list(
      fixed = ss[["formula"]][["model"]],
      data = quote(ss[["df"]]),
      random = ss[["formula"]][["random"]],
      weights = ss[["formula"]][["weights"]],
      correlation = ss[["formula"]][["cor_form"]],
      control = nlme::lmeControl(returnObject = TRUE, ...)
    )
  )
  return(fit)
}


#' Ease of use nls wrapper function for fitting growth models specified by \code{growthSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{growthSS}.
#' @param ... Additional arguments passed to \code{stats::nls}.
#' @keywords nls
#' @return An \code{nls} object, see \code{?nls} for details.
#' @importFrom stats nls
#' @export

fitGrowthnls <- function(ss, ...) {
  fit <- stats::nls(
    formula = ss[["formula"]],
    data = ss[["df"]],
    start = ss[["start"]], ...
  )
  return(fit)
}

#' Ease of use lm wrapper function for fitting gams specified by \code{growthSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{growthSS}.
#' @param ... Additional arguments passed to \code{stats::lm}.
#' @keywords nls
#' @return An \code{lm} object, see \code{?lm} for details.
#' @importFrom stats lm
#' @export

fitGrowthnlsgam <- function(ss, ...) {
  fit <- stats::lm(
    formula = ss[["formula"]],
    data = ss[["df"]],
    weights = ss[["weights"]], ...
  )
  return(fit)
}

#' Ease of use lm wrapper function for fitting growth models specified by \code{mvSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{mvSS}.
#' @param ... Additional arguments passed to \code{stats::lm}.
#' @keywords nls
#' @return An \code{lm} object, see \code{?lm} for details.
#' @importFrom stats lm
#' @export

fitGrowthlm <- function(ss, ...) {
  fit <- do.call("lm", args = list(
    formula = ss[["formula"]],
    data = quote(ss[["df"]]),
    weights = ss[["weights"]], ...
  ))
  ocall <- as.character(fit$call)
  ocall[4] <- "weights"
  fit$call <- as.call(str2expression(ocall))
  return(fit)
}

#' Ease of use nlrq wrapper function for fitting growth models specified by \code{growthSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{growthSS}.
#' @param cores Optionally specify how many cores to run in parallel if ss$taus is >1L.
#' Defaults to 1 if mc.cores option is not set globally.
#' @param ... Additional arguments passed to \code{quantreg::nlrq}.
#' @keywords nls
#' @return An \code{nlrqModel} object if tau is length of 1 or a list of such models for multiple taus,
#'   see \code{?quantreg::nlrq} or \code{?nls::nlsModel} for details.
#' @importFrom parallel mclapply
#' @importFrom quantreg nlrq
#' @export

fitGrowthnlrq <- function(ss, cores = getOption("mc.cores", 1), ...) {
  if (length(ss[["taus"]]) > 1) {
    fits <- parallel::mclapply(ss[["taus"]], function(tau) {
      fit <- do.call("nlrq", args = list(
        formula = ss[["formula"]],
        data = quote(ss[["df"]]),
        tau = tau,
        start = ss[["start"]], ...
      ))
      return(fit)
    }, mc.cores = cores)
    names(fits) <- ss[["taus"]]
  } else {
    fits <- do.call("nlrq", args = list(
      formula = ss[["formula"]],
      data = quote(ss[["df"]]),
      tau = ss[["taus"]],
      start = ss[["start"]], ...
    ))
  }
  return(fits)
}

#' Ease of use rq wrapper function for fitting gams specified by \code{growthSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{growthSS}.
#' @param cores number of cores to run in parallel
#' @param ... Additional arguments passed to \code{quantreg::rq}.
#' @keywords nls
#' @return An \code{rq} object, see \code{?rq} for details.
#' @importFrom quantreg rq
#' @export

fitGrowthnlrqgam <- function(ss, cores = getOption("mc.cores", 1), ...) {
  if (length(ss[["taus"]]) > 1) {
    fits <- parallel::mclapply(ss[["taus"]], function(tau) {
      fit <- do.call("rq", args = list(
        formula = ss[["formula"]],
        data = quote(ss[["df"]]),
        tau = tau,
        ...
      ))
      return(fit)
    }, mc.cores = cores)
    names(fits) <- ss[["taus"]]
  } else {
    fits <- do.call("rq", args = list(
      formula = ss[["formula"]],
      data = quote(ss[["df"]]),
      tau = ss[["taus"]],
      ...
    ))
  }
  return(fits)
}

#' Ease of use rq wrapper function for fitting models specified by \code{mvSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{mvSS}.
#' @param cores number of cores to run in parallel
#' @param ... Additional arguments passed to \code{quantreg::rq}.
#' @keywords nls
#' @return An \code{rq} object, see \code{?rq} for details.
#' @importFrom quantreg rq
#' @export

fitGrowthrq <- function(ss, cores = getOption("mc.cores", 1), ...) {
  if (length(ss[["taus"]]) > 1) {
    fits <- parallel::mclapply(ss[["taus"]], function(tau) {
      fit <- do.call("rq", args = list(
        formula = ss[["formula"]],
        data = quote(ss[["df"]]),
        weights = ss[["weights"]],
        tau = tau,
        ...
      ))
      ocall <- as.character(fit$call)
      ocall[5] <- "weights"
      fit$call <- as.call(str2expression(ocall))
      return(fit)
    }, mc.cores = cores)
    names(fits) <- ss[["taus"]]
  } else {
    fits <- do.call("rq", args = list(
      formula = ss[["formula"]],
      data = quote(ss[["df"]]),
      weights = ss[["weights"]],
      tau = ss[["taus"]],
      ...
    ))
    ocall <- as.character(fits$call)
    ocall[5] <- "weights"
    fits$call <- as.call(str2expression(ocall))
  }
  return(fits)
}

#' Ease of use mgcv wrapper function for fitting gams specified by \code{growthSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{growthSS}.
#' @param ... Additional arguments passed to \code{mgcv::gam}.
#' @keywords mgcv gam
#' @return An \code{gam} object, see \code{?gam} for details.
#' @importFrom mgcv gam s
#' @export

fitGrowthmgcvgam <- function(ss, ...) {
  fit <- do.call("gam", args = list(
    formula = ss[["formula"]],
    data = ss[["df"]],
    ...
  ))
  return(fit)
}


#' Ease of use wrapper function for fitting growth models specified by \code{growthSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{growthSS}.
#' @param ... Additional arguments passed to \code{survival::survreg}.
#' @keywords nlme
#' @return A \code{survreg} object.
#' @importFrom survival survreg Surv
#' @export

fitGrowthsurvreg <- function(ss, ...) {
  fit <- do.call("survreg", args = list(
    formula = ss[["formula"]],
    data = quote(ss[["df"]]),
    dist = ss[["distribution"]],
    ...
  ))
  return(fit)
}

#' Ease of use wrapper function for fitting growth models specified by \code{growthSS}
#'
#' Helper function generally called from \link{fitGrowth}.
#'
#' @param ss A list generated by \code{growthSS}.
#' @param ... Additional arguments passed to \code{flexsurv::flexsurvreg}.
#' @keywords flexsurv
#' @return A \code{survreg} object.
#' @export

fitGrowthflexsurv <- function(ss, ...) {
  fit <- do.call(eval(parse(text = "flexsurv::flexsurvreg")), args = list(
    formula = ss[["formula"]][["f1"]],
    anc = ss[["formula"]][["f2"]],
    data = quote(ss[["df"]]),
    dist = ss[["distribution"]],
    ...
  ))
  return(fit)
}

#' Function to visualize common \code{quantreg::nlrq} growth models.
#'
#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
#' (and similar models made through other means)
#' can be visualized easily using this function. This will generally be called by \code{growthPlot}.
#'
#' @param fit A model fit, or list of model fits, returned by \code{fitGrowth} with type="nlrq".
#' @param form A formula similar to that in \code{growthSS} inputs (or the \code{pcvrForm} part of the
#' output) specifying the outcome, predictor, and grouping structure of the data as
#' \code{outcome ~ predictor|individual/group}. If the individual and group are specified then the
#' observed growth lines are plotted.
#' @param df A dataframe to use in plotting observed growth curves on top of the model.
#' This must be supplied for nlrq models.
#' @param groups An optional set of groups to keep in the plot.
#' Defaults to NULL in which case all groups in the model are plotted.
#' @param timeRange An optional range of times to use. This can be used to view predictions for
#' future data if the avaiable data has not reached some point (such as asymptotic size).
#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
#' @param groupFill logical, should groups have different colors? Defaults to FALSE.
#' If TRUE then viridis colormaps are used in the order of virMaps
#' @param virMaps order of viridis maps to use. Will be recycled to necessary length.
#' Defaults to "plasma", but will generally be informed by growthPlot's default.
#' @keywords growth-curve
#' @importFrom methods is
#' @import ggplot2
#' @importFrom stats setNames predict
#' @importFrom viridis plasma
#' @examples
#'
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   tau = c(0.5, 0.9), df = simdf, start = NULL, type = "nlrq"
#' )
#' fit <- fitGrowth(ss)
#' nlrqPlot(fit, form = ss$pcvrForm, df = ss$df, groups = "a", timeRange = 1:20)
#' nlrqPlot(fit, form = ss$pcvrForm, df = ss$df, groupFill = TRUE, virMaps = c("plasma", "viridis"))
#'
#' @return Returns a ggplot showing an nlrq model's quantiles
#'  and optionally the individual growth lines.
#'
#' @export

nlrqPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL,
                     facetGroups = TRUE, groupFill = FALSE, virMaps = c("plasma")) {
  #* `get needed information from formula`
  parsed_form <- .parsePcvrForm(form, df)
  y <- parsed_form$y
  x <- parsed_form$x
  individual <- parsed_form$individual
  if (individual == "dummyIndividual") {
    individual <- NULL
  }
  group <- parsed_form$group
  df <- parsed_form$data
  #* `filter by groups if groups != NULL`
  if (!is.null(groups)) {
    df <- df[df[[group]] %in% groups, ]
  }
  #* `make new data if timerange is not NULL`
  if (!is.null(timeRange)) {
    new_data <- do.call(rbind, lapply(unique(df[[group]]), function(g) {
      stats::setNames(data.frame(g, timeRange), c(group, x))
    }))
  } else {
    new_data <- NULL
  }
  #* `standardize fit class`
  if (methods::is(fit, "nlrq")) {
    fit <- list(fit)
    names(fit) <- fit[[1]]$m$tau()
  }
  #* `add predictions`
  preds <- do.call(cbind, lapply(fit, function(f) {
    tau <- f$m$tau()
    stats::setNames(data.frame(stats::predict(f, newdata = new_data)), paste0("Q_", tau))
  }))
  predCols <- colnames(preds)
  keep <- which(!duplicated(preds))
  plotdf <- cbind(df[keep, ], preds[keep, ])
  colnames(plotdf) <- c(colnames(df), colnames(preds))

  #* `facetGroups`
  facet_layer <- NULL
  if (facetGroups) {
    facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
  }
  #* `groupFill`
  if (groupFill) {
    virList <- lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
      virpal_p1 <- viridis::viridis(ceiling(length(predCols) / 2), direction = 1, end = 1, option = pal)
      virpal_p2 <- viridis::viridis(ceiling(length(predCols) / 2),
        direction = -1, end = 1, option = pal
      )[-1]
      c(virpal_p1, virpal_p2)
    })
  } else {
    virpal_p1 <- viridis::plasma(ceiling(length(predCols) / 2), direction = 1, end = 1)
    virpal_p2 <- viridis::plasma(ceiling(length(predCols) / 2), direction = -1, end = 1)[-1]
    virpal <- c(virpal_p1, virpal_p2)
    virList <- lapply(seq_along(unique(df[[group]])), function(i) {
      virpal
    })
  }
  #* `layer for individual lines if formula was complete`
  if (!is.null(individual)) {
    individual_lines <- ggplot2::geom_line(
      data = df, ggplot2::aes(
        x = .data[[x]], y = .data[[y]],
        group = interaction(
          .data[[individual]],
          .data[[group]]
        )
      ),
      linewidth = 0.25, color = "gray40"
    )
  } else {
    individual_lines <- list()
  }
  #* `plot`
  plot <- ggplot(plotdf, ggplot2::aes(group = interaction(.data[[group]]))) +
    facet_layer +
    individual_lines +
    labs(x = x, y = as.character(form)[2]) +
    pcv_theme()

  for (g in seq_along(unique(plotdf[[group]]))) {
    iteration_group <- unique(plotdf[[group]])[g]
    sub <- plotdf[plotdf[[group]] == iteration_group, ]
    plot <- plot +
      lapply(seq_along(predCols), function(i) {
        ggplot2::geom_line(
          data = sub, ggplot2::aes(x = .data[[x]], y = .data[[predCols[i]]]),
          color = virList[[g]][i], linewidth = 0.7
        )
      })
  }

  return(plot)
}

#' Reduce phenotypes in longitudinal data to cumulative sums of phenotypes.
#'
#'
#'
#' @description Often in bellwether experiments we are curious about the effect of
#'  some treatment vs control. For certain routes in analysing the data this requires
#'   considering phenotypes as relative differences compared to a control.
#'
#' @param df Dataframe to use, this can be in long or wide format.
#' @param phenotypes A character vector of column names for the phenotypes
#' that should be compared against control.
#' @param group A character vector of column names that identify groups in the data.
#' Defaults to "barcode". These groups will be calibrated separately, with the exception
#' of the group that identifies a control within the greater hierarchy.
#' @param timeCol Column name to use for time data.
#' @param traitCol Column with phenotype names, defaults to "trait".
#' This should generally not need to be changed from the default.
#'    If this and valueCol are present in colnames(df) then the data
#'    is assumed to be in long format.
#' @param valueCol Column with phenotype values, defaults to "value".
#'  This should generally not need to be changed from the default.
#' @return A dataframe with cumulative sum columns added for specified phenotypes
#' @keywords single-value-traits
#' @importFrom stats setNames
#' @examples
#' \donttest{
#' sv <- read.pcv(
#'   "https://raw.githubusercontent.com/joshqsumner/pcvrTestData/main/pcv4-single-value-traits.csv",
#'   reader = "fread"
#' )
#' sv$genotype <- substr(sv$barcode, 3, 5)
#' sv$genotype <- ifelse(sv$genotype == "002", "B73",
#'   ifelse(sv$genotype == "003", "W605S",
#'     ifelse(sv$genotype == "004", "MM", "Mo17")
#'   )
#' )
#' sv$fertilizer <- substr(sv$barcode, 8, 8)
#' sv$fertilizer <- ifelse(sv$fertilizer == "A", "100",
#'   ifelse(sv$fertilizer == "B", "50", "0")
#' )
#'
#' sv <- bw.time(sv,
#'   plantingDelay = 0, phenotype = "area_pixels", cutoff = 10,
#'   timeCol = "timestamp", group = c("barcode", "rotation"), plot = TRUE
#' )$data
#' sv <- bw.outliers(sv,
#'   phenotype = "area_pixels", group = c("DAS", "genotype", "fertilizer"),
#'   plotgroup = c("barcode", "rotation")
#' )$data
#' phenotypes <- colnames(sv)[19:35]
#' phenoForm <- paste0("cbind(", paste0(phenotypes, collapse = ", "), ")")
#' groupForm <- "DAS+DAP+barcode+genotype+fertilizer"
#' form <- as.formula(paste0(phenoForm, "~", groupForm))
#' sv <- aggregate(form, data = sv, mean, na.rm = TRUE)
#' pixels_per_cmsq <- 42.5^2 # pixel per cm^2
#' sv$area_cm2 <- sv$area_pixels / pixels_per_cmsq
#' sv$height_cm <- sv$height_pixels / 42.5
#' df <- sv
#' phenotypes <- c("area_cm2", "height_cm")
#' group <- c("barcode")
#' timeCol <- "DAS"
#' df <- cumulativePheno(df, phenotypes, group, timeCol)
#'
#'
#' sv_l <- read.pcv(
#'   "https://raw.githubusercontent.com/joshqsumner/pcvrTestData/main/pcv4-single-value-traits.csv",
#'   mode = "long", reader = "fread"
#' )
#' sv_l$genotype <- substr(sv_l$barcode, 3, 5)
#' sv_l$genotype <- ifelse(sv_l$genotype == "002", "B73",
#'   ifelse(sv_l$genotype == "003", "W605S",
#'     ifelse(sv_l$genotype == "004", "MM", "Mo17")
#'   )
#' )
#' sv_l$fertilizer <- substr(sv_l$barcode, 8, 8)
#' sv_l$fertilizer <- ifelse(sv_l$fertilizer == "A", "100",
#'   ifelse(sv_l$fertilizer == "B", "50", "0")
#' )
#' sv_l <- bw.time(sv_l,
#'   plantingDelay = 0, phenotype = "area_pixels", cutoff = 10,
#'   timeCol = "timestamp", group = c("barcode", "rotation")
#' )$data
#' sv_l <- cumulativePheno(sv_l,
#'   phenotypes = c("area_pixels", "height_pixels"),
#'   group = c("barcode", "rotation"), timeCol = "DAS"
#' )
#' }
#'
#' @export
#'
cumulativePheno <- function(df, phenotypes = NULL, group = "barcode", timeCol = "DAS",
                            traitCol = "trait", valueCol = "value") {
  if (all(c(traitCol, valueCol) %in% colnames(df))) {
    wide <- FALSE
  } else {
    wide <- TRUE
  }

  if (length(group) > 1) {
    df$GROUP <- as.character(interaction(df[, group]))
    group <- "GROUP"
  }

  if (!wide) {
    dat_sp <- split(df, df[[group]])
    out <- do.call(rbind, lapply(split(df, df[[group]]), function(d) {
      newRows <- do.call(rbind, lapply(phenotypes, function(pheno) {
        di <- d[d[[traitCol]] == pheno, ]
        di[[valueCol]] <- cumsum(di[[valueCol]])
        di[[traitCol]] <- paste0(pheno, "_csum")
        di
      }))
      rbind(d, newRows)
    }))
  } else {
    dat_sp <- split(df, df[[group]])
    out <- do.call(rbind, lapply(dat_sp, function(d) {
      d <- d[sort(d[[timeCol]], index.return = TRUE)$ix, ]
      d2 <- setNames(as.data.frame(do.call(cbind, lapply(phenotypes, function(pheno) {
        cumsum(d[[pheno]])
      }))), paste0(phenotypes, "_csum"))
      cbind(d, d2)
    }))
  }
  return(out)
}

#' Multi Value Trait Aggregation function
#'
#' @description EMD can get very heavy with large datasets. For an example
#' lemnatech dataset filtering for images from every 5th day there are
#' 6332^2 = 40,094,224 pairwise EMD values. In long format that's a 40 million row dataframe,
#' which is unwieldy. This function is to help reduce the size of datasets before
#' comparing histograms and moving on with matrix methods or network analysis.
#'
#' @param df A dataframe with multi value traits. This can be in wide or long format,
#' data is assumed to be long if traitCol, valueCol, and labelCol are present.
#' @param group Vector of column names for variables which uniquely identify groups
#' in the data to summarize data over. Typically this would be the design variables
#' and a time variable.
#' @param mvCols Either a vector of column names/positions representing multi value
#' traits or a character string that identifies the multi value trait columns as a
#' regex pattern. Defaults to "frequencies".
#' @param n_per_group Number of rows to return for each group.
#' @param outRows Optionally this is a different way to specify how many rows to return.
#' This will often not be exact so that groups have the same number of observations each.
#' @param keep A vector of single value traits to also average over groups, if there are
#' a mix of single and multi value traits in your data.
#' @param parallel Optionally the groups can be run in parallel with this number of cores,
#' defaults to 1 if the "mc.cores" option is not set globally.
#' @param traitCol Column with phenotype names, defaults to "trait".
#' @param labelCol Column with phenotype labels (units), defaults to "label".
#' @param valueCol Column with phenotype values, defaults to "value".
#' @param id Column that uniquely identifies images if the data is in long format.
#' This is ignored when data is in wide format.
#' @keywords emd multi-value-trait
#' @import parallel
#' @importFrom stats setNames aggregate as.formula
#' @examples
#'
#' s1 <- mvSim(
#'   dists = list(runif = list(min = 15, max = 150)),
#'   n_samples = 10,
#'   counts = 1000,
#'   min_bin = 1,
#'   max_bin = 180,
#'   wide = TRUE
#' )
#' mv_ag(s1, group = "group", mvCols = "sim_", n_per_group = 2)
#'
#' @return Returns a dataframe summarized by the specified groups over the multi-value traits.
#' @export

mv_ag <- function(df, group, mvCols = "frequencies", n_per_group = 1, outRows = NULL, keep = NULL,
                  parallel = getOption("mc.cores", 1),
                  traitCol = "trait", labelCol = "label", valueCol = "value", id = "image") {
  #* ***** [decide if data is long or wide]
  if (all(c(traitCol, valueCol, labelCol) %in% colnames(df))) {
    long <- TRUE
  } else if (!any(c(traitCol, valueCol, labelCol) %in% colnames(df))) {
    long <- FALSE
  } else {
    found <- c("traitCol", "valueCol", "labelCol")[which(c(
      traitCol,
      valueCol,
      labelCol
    ) %in% colnames(df))]
    stop(paste0(
      paste(found, collapse = ", "),
      " found in column names of data but either all or none of traitCol, ",
      "valueCol, and labelCol are expected."
    ))
  }


  #* ***** [calculated values]
  multi_group <- FALSE
  if (length(group) > 1) {
    original_group <- group
    df$INTERNAL_MULTI_GROUP <- as.character(interaction(df[, group]))
    group <- "INTERNAL_MULTI_GROUP"
    multi_group <- TRUE
  }


  #* ***** [wide column selection]
  if (!long) {
    if (length(mvCols) == 1 && is.character(mvCols)) {
      mvCols <- colnames(df)[grepl(mvCols, colnames(df))]
    }
    if (is.numeric(mvCols)) {
      mvCols <- colnames(df)[mvCols]
    }
  } else {
    #* ***** [long trait identification]

    df <- df[grepl(mvCols, df[[traitCol]]), ]
    if (length(unique(df[[traitCol]])) > 1) {
      stop(paste0(
        "In long format mvCols should only match one trait, ",
        mvCols, " matches ", paste0(unique(df[[traitCol]]), collapse = ", ")
      ))
    }
  }

  #* ***** [split data by group]

  dat_sp <- split(x = df, f = df[[group]])
  if (!is.null(outRows)) {
    n_per_group <- round(length(dat_sp) / outRows)
  }

  #* ***** [aggregate wide format data]
  if (!long) {
    out <- .mv_wide_ag(dat_sp, mvCols, n_per_group, parallel, group, keep)
  } else {
    #* ***** [aggregate long data]
    out <- .mv_long_ag(dat_sp, traitCol, valueCol, labelCol, n_per_group, parallel, group, keep, id)
  }

  if (multi_group) {
    group_df <- setNames(data.frame(out[[group]]), "group")
    group_df <- setNames(as.data.frame(
      do.call(rbind, lapply(
        group_df$group,
        function(s) {
          matrix(strsplit(s, split = "[.]")[[1]], nrow = 1)
        }
      ))
    ), original_group)
    out <- cbind(group_df, out[, -which(colnames(out) == "INTERNAL_MULTI_GROUP")])
  }

  return(out)
}

#' internal helper for wide aggregation
#' @keywords internal
#' @noRd

.mv_wide_ag <- function(dat_sp, mvCols, n_per_group, parallel, group, keep) {
  out <- do.call(rbind, parallel::mclapply(dat_sp, function(d) {
    mv <- as.matrix(d[, mvCols], rownames.force = TRUE)
    mv <- mv / rowSums(mv) # rescale everything to sum to 1
    if (nrow(mv) < n_per_group) {
      iter_n <- nrow(mv)
    } else {
      iter_n <- n_per_group
    }
    rownames(mv) <- seq_len(nrow(mv))
    nms <- sample(rownames(mv), nrow(mv), replace = FALSE)
    if (nrow(mv) > 1 & iter_n > 1) {
      index <- cut(seq_len(nrow(mv)), iter_n)
      nms_split <- split(nms, index)
    } else {
      nms_split <- list(rownames(mv))
    }

    mv_ag <- data.frame(do.call(rbind, lapply(nms_split, function(rwnms) {
      mvi <- matrix(mv[rwnms, ], nrow = length(rwnms))
      if (nrow(mvi) > 1) {
        matrix(colMeans(mvi), nrow = 1)
      } else {
        mvi
      }
    })))
    colnames(mv_ag) <- mvCols

    if (!is.null(keep)) {
      kept <- data.frame(do.call(rbind, lapply(nms_split, function(rwnms) {
        kp <- as.matrix(d[rwnms, keep])
        if (nrow(kp) > 1) {
          matrix(colMeans(kp), nrow = 1)
        } else {
          kp
        }
      })))
      colnames(kept) <- keep
      mv_ag <- cbind(kept, mv_ag)
    }

    mv_ag <- cbind(setNames(data.frame(rep(d[1, group], nrow(mv_ag))), group), mv_ag)
    return(mv_ag)
  }, mc.cores = parallel))
  return(out)
}

#' internal helper for long data aggregation
#' @keywords internal
#' @noRd

.mv_long_ag <- function(dat_sp, traitCol, valueCol, labelCol, n_per_group, parallel, group, keep, id) {
  out <- do.call(rbind, parallel::mclapply(dat_sp, function(d) {
    #* get unique images
    IDS <- unique(d[[id]])
    #* define number of possible groups
    if (length(IDS) < n_per_group) {
      iter_n <- length(IDS)
    } else {
      iter_n <- n_per_group
    }
    #* rescale values to sum to 1
    d <- do.call(rbind, lapply(IDS, function(i) {
      id_d <- d[d[[id]] == IDS, ]
      id_d[[valueCol]] <- id_d[[valueCol]] / sum(id_d[[valueCol]], na.rm = TRUE)
      return(id_d)
    }))
    #* separate IDS into groups
    if (length(IDS) > 1 & iter_n > 1) {
      index <- cut(seq_along(IDS), iter_n)
      ids_split <- split(IDS, index)
    } else {
      ids_split <- list(IDS)
    }

    #* mean of bin per groups
    mv_ag <- data.frame(do.call(rbind, lapply(ids_split, function(ids) {
      d_group <- d[d[[id]] %in% ids, ]
      aggregate(
        as.formula(paste0(
          valueCol, "~",
          paste0(c(labelCol, traitCol, group), collapse = "+")
        )),
        d_group, mean,
        na.rm = TRUE
      )
    })))
    #* add back in kept traits
    if (!is.null(keep)) {
      kept <- d[d[[traitCol]] %in% keep, ]
      mv_ag <- cbind(mv_ag, kept)
    }
    rownames(mv_ag) <- NULL
    return(mv_ag)
  }, mc.cores = parallel))
  return(out)
}

#' Function to help fulfill elements of the Bayesian Analysis Reporting Guidelines.
#'
#' The Bayesian Analysis Reporting Guidelines were put forward by Kruschke
#' (https://www.nature.com/articles/s41562-021-01177-7) to aide in reproducibility and documentation
#' of Bayesian statistical analyses that are sometimes unfamiliar to reviewers or scientists.
#' The purpose of this function is to summarize goodness of fit metrics from one or more Bayesian models
#' made by \link{growthSS} and \link{fitGrowth}. See details for explanations of those metrics and
#' the output.
#'
#' @param fit The brmsfit object or a list of brmsfit objects in the case that you split models to run
#' on subsets of the data for computational simplicity.
#' @param ss The growthSS output used to specify the model. If fit is a list then this can either be one
#' growthSS list in which case the priors are assumed to be the same for each model or it can be a list
#' of the same length as fit. Note that the only parts of this which are used are the \code{call$start}
#' which is expected to be a call, \code{pcvrForm}, and \code{df} list elements,
#' so if you have a list of brmsfit objects and no ss object you can specify a stand-in list. This
#' can also be left NULL (the default) and posterior predictive plots and prior predictive plots will
#' not be made.
#'
#'
#' @details
#'
#'
#' \itemize{
#'     \item \bold{General}: This includes chain number, length, and total divergent transitions per
#'     model. Divergent transitions are a marker that the MCMC had something go wrong.
#'     Conceptually it may be helpful to think about rolling a marble over a 3D curve then having the
#'     marble suddenly jolt in an unexpected direction, something happened that suggests a
#'     problem/misunderstood surface. In practice you want extremely few (ideally no) divergences.
#'     If you do have divergences then consider specifying more control parameters
#'     (see brms::brm or examples for \link{fitGrowth}). If the problem persists then the model may need
#'     to be simplified. For more information on MCMC and divergence see the stan
#'     manual (https://mc-stan.org/docs/2_19/reference-manual/divergent-transitions).
#'
#'     \item \bold{ESS}: ESS stands for Effective Sample Size and is a goodness of fit metric that
#'     approximates the number of independent replicates that would equate to the same amount of
#'     information as the (autocorrelated) MCMC iterations. ESS of 1000+ is often considered as a pretty
#'     stable value, but more is better. Still, 100 per chain may be plenty depending on your
#'     applications and the inference you wish to do. One of the benefits to using lots of chains and/or
#'     longer chains is that you will get more complete information and that benefit will be shown by a
#'     larger ESS. This is separated into "bulk" and "tail" to represent the middle and tails of the
#'     posterior distribution, since those can sometimes have very different sampling behavior.
#'     A summary and the total values are returned, with the summary being useful if several models are
#'     included in a list for fit argument
#'
#'     \item \bold{Rhat}: Rhat is a measure of "chain mixture". It compares the between vs within chain
#'     values to assess how well the chains mixed. If chains did not mix well then Rhat will be greater
#'     than 1, with 1.05 being a broadly
#'     agreed upon cutoff to signify a problem. Running longer chains should result in lower Rhat
#'     values. The default in brms is to run 4 chains, partially to ensure that there is a good chance
#'     to check that the chains mixed well via Rhat. A summary and the total values are returned, with
#'     the summary being useful if several models are included in a list for fit argument
#'
#'     \item \bold{NEFF}: NEFF is the NEFF ratio (Effective Sample Size over Total MCMC Sample Size).
#'     Values greater than 0.5 are generally considered good, but there is a consensus that lower can be
#'     fine down to about 0.1. A summary and the total values are returned, with the summary being
#'     useful if several models are included in a list for fit argument
#'
#'     \item \bold{priorPredictive}: A plot of data simulated from the prior using \link{plotPrior}.
#'     This should generate data that is biologically plausible for your situation, but it will
#'     probably be much more variable than your data. That is the effect of the mildly informative thick
#'     tailed lognormal priors. If you specified non-default style priors then this currently will not
#'     work.
#'
#'     \item \bold{posteriorPredictive}: A plot of each model's posterior predictive interval over time.
#'     This is the same as plots returned from \link{growthPlot} and shows 1-99% intervals in purple
#'     coming to a mean yellow trend line. These should encompass the overwhelming majority of your data
#'     and ideally match the variance pattern that you see in your data. If parts of the predicted
#'     interval are biologically impossible (area below 0, percentage about 100%, etc) then your chosen
#'     model should be reconsidered.
#'     }
#'
#'
#'
#'
#' @keywords Bayesian brms prior
#' @return A named list containing Rhat, ESS, NEFF, and Prior/Posterior Predictive plots.
#' See details for interpretation.
#' @importFrom rlang is_installed
#'
#' @examples
#'
#' \donttest{
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group, sigma = "logistic",
#'   df = simdf, start = list(
#'     "A" = 130, "B" = 12, "C" = 3,
#'     "sigmaA" = 20, "sigmaB" = 10, "sigmaC" = 2
#'   ), type = "brms"
#' )
#' fit_test <- fitGrowth(ss,
#'   iter = 600, cores = 1, chains = 1, backend = "cmdstanr",
#'   sample_prior = "only" # only sampling from prior for speed
#' )
#' barg(fit_test, ss)
#' fit_2 <- fit_test
#' fit_list <- list(fit_test, fit_2)
#' x <- barg(fit_list, list(ss, ss))
#' }
#'
#' @export

barg <- function(fit, ss = NULL) {
  out <- list()
  #* `format everything into lists`
  if (methods::is(fit, "brmsfit")) {
    fitList <- list(fit)
  } else {
    fitList <- fit
  }
  if (!is.null(names(ss)) && names(ss)[1] == "formula") {
    ssList <- lapply(seq_along(fitList), function(i) {
      ss
    })
  } else {
    ssList <- ss
  }
  #* `General Info`
  general <- do.call(rbind, lapply(seq_along(fitList), function(i) {
    fitobj <- fitList[[i]]
    ms <- summary(fitobj)
    data.frame(
      chains = ms$chains,
      iter = ms$iter,
      num.divergent = rstan::get_num_divergent(fitobj$fit),
      model = i
    )
  }))
  out[["General"]] <- general
  #* `Rhat summary`
  rhats <- do.call(rbind, lapply(fitList, function(fitobj) {
    brms::rhat(fitobj)
  }))
  rhat_metrics <- apply(rhats, MARGIN = 2, summary)
  rhats$model <- seq_along(fitList)
  out[["Rhat"]][["summary"]] <- rhat_metrics
  out[["Rhat"]][["complete"]] <- rhats
  #* `NEFF summary`
  neff <- do.call(rbind, lapply(fitList, function(fitobj) {
    brms::neff_ratio(fitobj)
  }))
  neff_metrics <- apply(neff, MARGIN = 2, summary)
  neff$model <- seq_along(fitList)
  out[["NEFF"]][["summary"]] <- neff_metrics
  out[["NEFF"]][["complete"]] <- neff
  #* `ESS Summary`
  ess <- do.call(rbind, lapply(seq_along(fitList), function(i) {
    fit <- fitList[[i]]
    ms <- summary(fit)
    data.frame(
      "par" = c(rownames(ms$fixed), rownames(ms$spec_pars)),
      "Bulk_ESS" = c(ms$fixed$Bulk_ESS, ms$spec_pars$Bulk_ESS),
      "Tail_ESS" = c(ms$fixed$Tail_ESS, ms$spec_pars$Tail_ESS),
      "model" = i
    )
  }))
  ag_b_ess <- aggregate(Bulk_ESS ~ par, ess, summary)
  tag_b_ess <- t(ag_b_ess[-1])
  colnames(tag_b_ess) <- ag_b_ess[, 1]
  ag_t_ess <- aggregate(Tail_ESS ~ par, ess, summary)
  tag_t_ess <- t(ag_t_ess[-1])
  colnames(tag_t_ess) <- ag_t_ess[, 1]
  ess_metrics <- rbind(tag_b_ess, tag_t_ess)
  out[["ESS"]][["summary"]] <- ess_metrics
  out[["ESS"]][["complete"]] <- ess
  #* `Prior Predictive Check`
  if (methods::is(eval(ssList[[1]]$call$start), "list")) {
    pri_preds <- lapply(seq_along(ssList), function(i) {
      ss <- ssList[[i]]
      x <- trimws(gsub("[|].*|[/].*", "", as.character(ss$pcvrForm)[3]))
      t <- max(ss$df[[x]])
      pri_pred <- plotPrior(priors = eval(ss$call$start), type = ss$model, n = 200, t = t)
      pri_pred$simulated
    })
    out[["priorPredictive"]] <- pri_preds
  }
  #* `Posterior Predictive Check`
  if (methods::is(eval(ssList[[1]]$pcvrForm), "formula")) {
    post_preds <- lapply(seq_along(fitList), function(i) {
      brmPlot(fitList[[i]], form = ssList[[i]]$pcvrForm, df = ssList[[i]]$df)
    })
    out[["posteriorPredictive"]] <- post_preds
  }
  return(out)
}

#' @description
#' Internal function for Bayesian T Tests of gaussian data represented by single value traits.
#' @param s1 A vector of numerics drawn from a gaussian distribution.
#' @examples
#' \donttest{
#' .conj_t_sv(
#'   s1 = rnorm(100, 50, 10), s2 = rnorm(100, 60, 12),
#'   priors = list(mu = c(0, 0), n = c(1, 1), s2 = c(20, 20)),
#'   plot = FALSE, rope_range = c(-0.1, 0.1), rope_ci = 0.89,
#'   cred.int.level = 0.89, hypothesis = "equal", support = NULL
#' )
#' }
#' @keywords internal
#' @noRd
.conj_t_sv <- function(s1 = NULL, priors = NULL,
                       plot = FALSE, support = NULL, cred.int.level = NULL,
                       calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(mu = 0, n = 1, s2 = 100)
  }
  #* `Get Mean, Variance, SE, and DF from s1`
  n1 <- length(s1) # n samples
  m1 <- mean(s1) # xbar
  s2_1 <- var(s1) # var

  v1 <- priors$n[1] - 1 # prior DF
  n1_n <- priors$n[1] + n1 # total N including prior
  m1_n <- (n1 * m1 + priors$n[1] * priors$mu[1]) / n1_n # weighted mean of prior and data
  v1_n <- v1 + n1 # degrees of freedom including data
  s2_1_n <- ((n1 - 1) * s2_1 + v1 * priors$s2[1] + priors$n[1] * n1 * (priors$mu[1] - m1)^2 / n1_n) /
    v1_n # pooled variance
  se1 <- sqrt(s2_1_n / n1_n) # standard error of the mean
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qlst(c(0.0001, 0.9999), v1_n, m1_n, se1)
    return(quantiles)
  }
  dens <- extraDistr::dlst(support, v1_n, m1_n, se1)
  pdf1 <- dens / sum(dens)
  hde1_mean <- m1_n
  hdi1_mean <- m1_n + qt(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), v1_n) * se1

  out$summary <- data.frame(HDE_1 = hde1_mean, HDI_1_low = hdi1_mean[1], HDI_1_high = hdi1_mean[2])
  out$posterior$mu <- m1_n
  out$posterior$n <- n1_n
  out$posterior$s2 <- s2_1_n # return variance
  #* `Make Posterior Draws`
  out$posteriorDraws <- extraDistr::rlst(10000, v1_n, m1_n, se1)
  out$pdf <- pdf1
  #* `Save data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}





#' @description
#' Internal function for calculating \alpha and \beta of a distribution represented by multi value
#' traits.
#' @param s1 A data.frame or matrix of multi value traits. The column names should include a number
#' representing the "bin".
#' @examples
#' \donttest{
#' mv_gauss <- mvSim(
#'   dists = list(
#'     rnorm = list(mean = 50, sd = 10)
#'   ),
#'   n_samples = 30
#' )
#' .conj_t_mv(
#'   s1 = mv_gauss[1:30, -1],
#'   priors = NULL,
#'   plot = TRUE,
#'   cred.int.level = 0.89
#' )
#' }
#' @keywords internal
#' @noRd

.conj_t_mv <- function(s1 = NULL, priors = NULL,
                       plot = FALSE, support = NULL, cred.int.level = NULL,
                       calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(mu = 0, n = 1, s2 = 100)
  }
  #* `Reorder columns if they are not in the numeric order`
  histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
  bins_order <- sort(histColsBin, index.return = TRUE)$ix
  s1 <- s1[, bins_order]

  #* `Turn s1 matrix into a vector`
  X1 <- rep(histColsBin[bins_order], as.numeric(round(colSums(s1))))

  #* `Get Mean, Variance, SE, and DF from s2`
  n1 <- nrow(s1) # n samples
  m1 <- mean(X1) # xbar
  s2_1 <- var(X1) # var

  v1 <- priors$n[1] - 1 # prior DF
  n1_n <- priors$n[1] + n1 # total N including prior
  m1_n <- (n1 * m1 + priors$n[1] * priors$mu[1]) / n1_n # weighted mean of prior and data
  v1_n <- v1 + n1 # degrees of freedom including data
  s2_1_n <- ((n1 - 1) * s2_1 + v1 * priors$s2[1] + priors$n[1] * n1 * (priors$mu[1] - m1)^2 / n1_n) /
    v1_n # pooled variance
  se1 <- sqrt(s2_1_n / n1_n) # standard error of the mean
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qlst(c(0.0001, 0.9999), v1_n, m1_n, se1)
    return(quantiles)
  }
  dens <- extraDistr::dlst(support, v1_n, m1_n, se1)
  pdf1 <- dens / sum(dens)
  hde1_mean <- m1_n
  hdi1_mean <- m1_n + qt(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), v1_n) * se1

  out$summary <- data.frame(HDE_1 = hde1_mean, HDI_1_low = hdi1_mean[1], HDI_1_high = hdi1_mean[2])
  out$posterior$mu <- m1_n
  out$posterior$n <- n1_n
  out$posterior$s2 <- s2_1_n
  #* `Make Posterior Draws`
  out$posteriorDraws <- extraDistr::rlst(10000, v1_n, m1_n, se1)
  out$pdf <- pdf1
  #* `Save data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }

  return(out)
}

#' helper function to help make growth models including an intercept term in growthSS
#' @examples
#' .intModelHelper("int_logistic")
#' .intModelHelper("logistic")
#'
#' @keywords internal
#' @noRd

.intModelHelper <- function(model) {
  if (grepl("int_", model)) {
    int <- TRUE
    model <- gsub("int_", "", model)
  } else {
    int <- FALSE
  }
  return(list("model" = model, "int" = int))
}

#' @description
#' Internal function for Bayesian comparisosns of gaussian data represented by single value traits.
#' This version uses the entire posterior distribution instead of the sampling distribution of the mean.
#' In frequentist terms this is analogous to a Z test as opposed to a T test. Generally the T test is
#' desired, but this is provided for completeness.
#' @param s1 A vector of numerics drawn from a gaussian distribution.
#' @examples
#' .conj_gaussian_sv(
#'   s1 = rnorm(100, 50, 10),
#'   priors = list(mu = c(0, 0), n = c(1, 1), s2 = c(20, 20)),
#'   plot = FALSE, support = NULL
#' )
#' @keywords internal
#' @noRd

.conj_gaussian_sv <- function(s1 = NULL, priors = NULL,
                              plot = FALSE, support = NULL, cred.int.level = NULL,
                              calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(mu = 0, n = 1, s2 = 100)
  }
  #* `Get Mean, Variance, SE, and DF from s1`

  n1 <- length(s1) # n samples
  m1 <- mean(s1) # xbar
  s2_1 <- var(s1) # variance
  v1 <- priors$n[1] - 1 # prior DF
  n1_n <- priors$n[1] + n1 # total N including prior
  m1_n <- (n1 * m1 + priors$n[1] * priors$mu[1]) / n1_n # weighted mean of prior and data
  v1_n <- v1 + n1 # degrees of freedom including data
  s2_1_n <- ((n1 - 1) * s2_1 + v1 * priors$s2[1] + priors$n[1] * n1 * (priors$mu[1] - m1)^2 / n1_n) /
    v1_n # pooled variance
  sigma_1 <- sqrt(s2_1_n)
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qlst(c(0.0001, 0.9999), v1_n, m1_n, sigma_1)
    return(quantiles)
  }

  dens1 <- extraDistr::dlst(support, v1_n, m1_n, sigma_1)
  pdf1 <- dens1 / sum(dens1)
  hde1_mean <- m1_n
  hdi1_mean <- m1_n + qt(c(
    (1 - cred.int.level) / 2,
    (1 - ((1 - cred.int.level) / 2))
  ), v1_n) * sigma_1

  out$summary <- data.frame(HDE_1 = hde1_mean, HDI_1_low = hdi1_mean[1], HDI_1_high = hdi1_mean[2])
  out$posterior$mu <- m1_n
  out$posterior$n <- n1_n
  out$posterior$s2 <- s2_1_n # return variance
  #* `Make Posterior Draws`
  out$posteriorDraws <- extraDistr::rlst(10000, v1_n, m1_n, sigma_1)
  out$pdf <- pdf1
  #* `Save data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}


#' @description
#' Internal function for Bayesian comparisons of gaussian data represented by multi value traits.
#' This version uses the entire posterior distribution instead of the sampling distribution of the mean.
#' In frequentist terms this is analogous to a Z test as opposed to a T test. Generally the T test is
#' desired, but this is provided for completeness.
#' @param s1 A vector of numerics drawn from a gaussian distribution.
#' @keywords internal
#' @noRd

.conj_gaussian_mv <- function(s1 = NULL, priors = NULL,
                              plot = FALSE, support = NULL, cred.int.level = NULL,
                              calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(mu = 0, n = 1, s2 = 100)
  }
  #* `Reorder columns if they are not in the numeric order`
  histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
  bins_order <- sort(histColsBin, index.return = TRUE)$ix
  s1 <- s1[, bins_order]


  #* `Turn s1 matrix into a vector`
  X1 <- rep(histColsBin[bins_order], as.numeric(round(colSums(s1))))

  #* `Get Mean, Variance, SE, and DF from s2`
  n1 <- nrow(s1) # n samples
  m1 <- mean(X1) # xbar
  s2_1 <- var(X1) # var

  v1 <- priors$n[1] - 1 # prior DF
  n1_n <- priors$n[1] + n1 # total N including prior
  m1_n <- (n1 * m1 + priors$n[1] * priors$mu[1]) / n1_n # weighted mean of prior and data
  v1_n <- v1 + n1 # degrees of freedom including data
  s2_1_n <- ((n1 - 1) * s2_1 + v1 * priors$s2[1] + priors$n[1] * n1 * (priors$mu[1] - m1)^2 / n1_n) /
    v1_n # pooled variance
  sigma_1 <- sqrt(s2_1_n) # standard deviation
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qlst(c(0.0001, 0.9999), v1_n, m1_n, sigma_1)
    return(quantiles)
  }
  dens <- extraDistr::dlst(support, v1_n, m1_n, sigma_1)
  pdf1 <- dens / sum(dens)
  hde1_mean <- m1_n
  hdi1_mean <- m1_n + qt(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), v1_n) * sigma_1

  out$summary <- data.frame(HDE_1 = hde1_mean, HDI_1_low = hdi1_mean[1], HDI_1_high = hdi1_mean[2])
  out$posterior$mu <- m1_n
  out$posterior$n <- n1_n
  out$posterior$s2 <- s2_1_n
  #* `Make Posterior Draws`
  out$posteriorDraws <- extraDistr::rlst(10000, v1_n, m1_n, sigma_1)
  out$pdf <- pdf1
  #* `Save data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' Make Joyplots for multi value trait plantCV data
#'
#' @param df Data frame to use. Long or wide format is accepted.
#' @param index If the data is long then this is a multi value trait as a
#' character string that must be present in `trait`.
#' If the data is wide then this is a string used to find column names to use from the wide data.
#'  In the wide case this should include the entire
#'   trait name (ie, "hue_frequencies" instead of "hue_freq").
#' @param group A length 1 or 2 character vector.
#' This is used for faceting the joyplot and identifying groups for testing.
#' If this is length 1 then no faceting is done.
#' @param y Optionally a variable to use on the y axis. This is useful when you
#' have three variables to display. This argument will change faceting behavior to
#' add an additional layer of faceting (single length group will be faceted,
#' length 2 group will be faceted group1 ~ group2).
#' @param id Optionally a variable to show the outline of different replicates.
#' Note that ggridges::geom_density_ridges_gradient does not support transparency,
#' so if fillx is TRUE then only the outer line will show individual IDs.
#' @param bin Column containing histogram (multi value trait) bins. Defaults to "label".
#' @param freq Column containing histogram counts. Defaults to "value"
#' @param trait Column containing phenotype names. Defaults to "trait".
#' @param fillx Logical, whether or not to use \code{ggridges::geom_density_ridges_gradient}.
#'  Default is T, if F then \code{ggridges::geom_density_ridges} is used instead,
#'   with arbitrary fill. Note that \code{ggridges::geom_density_ridges_gradient}
#'   may issue a message about deprecated ggplot2 features.
#' @keywords multi-value-trait
#' @import ggplot2
#' @import ggridges
#' @import data.table
#' @importFrom stats setNames density aggregate as.formula ks.test
#'
#'
#' @return Returns a ggplot.
#'
#' @examples
#'
#' library(extraDistr)
#' dists <- list(
#'   rmixnorm = list(mean = c(70, 150), sd = c(15, 5), alpha = c(0.3, 0.7)),
#'   rnorm = list(mean = 90, sd = 20),
#'   rlnorm = list(meanlog = log(40), sdlog = 0.5)
#' )
#' x_wide <- mvSim(
#'   dists = dists, n_samples = 5, counts = 1000,
#'   min_bin = 1, max_bin = 180, wide = TRUE
#' )
#' pcv.joyplot(x_wide, index = "sim", group = "group")
#' x_long <- mvSim(
#'   dists = dists, n_samples = 5, counts = 1000,
#'   min_bin = 1, max_bin = 180, wide = FALSE
#' )
#' x_long$trait <- "x"
#' p <- pcv.joyplot(x_long, bin = "variable", group = "group")
#' # we might want to display hues as their hue
#' p + ggplot2::scale_fill_gradientn(colors = scales::hue_pal(l = 65)(360))
#' x_long$group2 <- "example"
#' pcv.joyplot(x_long, bin = "variable", y = "group", fillx = FALSE)
#'
#' @export

pcv.joyplot <- function(df = NULL, index = NULL, group = NULL, y = NULL, id = NULL,
                        bin = "label", freq = "value", trait = "trait", fillx = TRUE) {
  #* ***** `general calculated values`

  if (!is.null(trait) && trait %in% colnames(df)) {
    mode <- "long" # if there is a trait column then use long options,
  } else {
    mode <- "wide"
  } # else use wide options

  sub <- .joyPlotFormatData(mode, df, index, trait, bin, freq, group, y, id)

  if (is.null(group)) {
    group <- "dummy"
    df$dummy <- "dummy"
    sub$dummy <- "dummy"
  }

  joyPlotFacetHelperResult <- .joyPlotFacetHelper(y, group, sub)
  facet_layer <- joyPlotFacetHelperResult[["facet"]]
  sub <- joyPlotFacetHelperResult[["data"]]
  sub$grouping <- interaction(sub[, c(y, group)], drop = TRUE)

  #* `if ID is null then aggregate, else draw with ID`
  if (is.null(id)) {
    sub <- stats::aggregate(freq ~ ., data = sub, FUN = mean, na.rm = TRUE)
    gg <- ggplot2::ggplot(sub)
  } else {
    sub$id <- sub[[id]]
    gg <- ggplot2::ggplot(sub, ggplot2::aes(alpha = 0.5, group = interaction(id, y, grouping)))
  }

  ggridgeLayer <- if (fillx) {
    x <- NULL # to make R CMD check happy with stat(x)
    list(
      suppressMessages(ggridges::geom_density_ridges_gradient(
        ggplot2::aes(
          x = .data$bin, y = .data$y,
          height = .data$freq, fill = ggplot2::after_stat(x)
        ),
        show.legend = FALSE, stat = "identity", rel_min_height = 0.001
      )),
      ggplot2::scale_fill_viridis_c(
        option = "plasma"
      )
    )
  } else {
    list(
      suppressMessages(ggridges::geom_density_ridges2(
        ggplot2::aes(
          x = .data$bin, y = .data$y,
          height = .data$freq, fill = .data[[group]], color = .data[[group]]
        ),
        show.legend = FALSE, stat = "identity"
      )),
      ggplot2::scale_color_viridis_d(option = "viridis"),
      ggplot2::scale_fill_viridis_d(option = "viridis")
    )
  }
  p <- gg +
    facet_layer +
    ggridgeLayer +
    ggplot2::scale_x_continuous(n.breaks = 5, labels = ~ round(., 1)) +
    ggplot2::labs(x = index, y = c(y, group)[1]) +
    pcv_theme() +
    ggplot2::theme(legend.position = "none")
  return(p)
}


#' ***********************************************************************************************
#' *************** `format data` ****************************************
#' ***********************************************************************************************
#'
#' @description
#' Internal function for formatting MV trait data
#'
#' @keywords internal
#' @noRd

.joyPlotFacetHelper <- function(y, group, sub) {
  if (!is.null(y)) {
    if (length(group) == 1) {
      sub$y <- sub[[y]]
      facet_layer <- ggplot2::facet_grid(as.formula(paste0("~", group[1])))
    }
    if (length(group) == 2) {
      sub$y <- sub[[y]]
      facet_layer <- ggplot2::facet_grid(as.formula(paste0(group[1], "~", group[2])))
    }
    sub$y <- as.character(sub$y)
  } else { # if y is not provided then one less layer of faceting
    if (length(group) == 1) {
      sub$y <- sub[[group]]
      facet_layer <- list()
    }
    if (length(group) == 2) {
      sub$y <- sub[[group[1]]]
      facet_layer <- ggplot2::facet_grid(as.formula(paste0("~", group[2])))
    }
  }
  return(list("data" = sub, "facet" = facet_layer))
}


#' ***********************************************************************************************
#' *************** `format data` ****************************************
#' ***********************************************************************************************
#'
#' @description
#' Internal function for formatting MV trait data
#'
#' @keywords internal
#' @noRd

.joyPlotFormatData <- function(mode, df, index, trait, bin, freq, group, y, id) {
  #* if long data then subset rows where trait is correct
  if (mode == "long") {
    if (is.null(index)) {
      sub <- df
    } else {
      sub <- df[df[[trait]] == index, ]
    }
    if (length(unique(sub[[trait]])) > 1) {
      warning("More than one trait found, consider an `index` argument")
    }
    sub$bin <- as.numeric(sub[[bin]])
    sub$freq <- as.numeric(sub[[freq]])
    sub <- sub[, c(group, y, id, "bin", "freq", trait)]
  } else if (mode == "wide") { # if wide then get column names that contain index string
    #* subset data to only have index columns
    #* turn the data longer
    sub_wide <- data.table::as.data.table(
      df[, which(colnames(df) %in% c(group, y, id) | grepl(index, colnames(df)))]
    )
    sub <- as.data.frame(data.table::melt(sub_wide,
      id.vars = c(group, y, id),
      variable.name = trait, value.name = freq
    ))
    sub[[bin]] <- sub(index, "", sub[[trait]])
    sub$bin <- as.numeric(regmatches(sub[[bin]], regexpr("[0-9].*", sub[[bin]])))
    sub[[trait]] <- index
    sub$freq <- as.numeric(sub[[freq]])
    sub <- sub[, c(group, y, id, "bin", "freq", trait)]
  }
  return(sub)
}

#' @description
#' Internal function for calculating the beta distribution of the success rate of a bernoulli
#' distribution represented by single value traits.
#' @param s1 A vector of numerics drawn from a uniform distribution.
#' @examples
#' out <- .conj_bernoulli_sv(
#'   s1 = sample(c(TRUE, FALSE), 10, prob = c(0.3, 0.7), replace = TRUE),
#'   cred.int.level = 0.95,
#'   plot = TRUE
#' )
#' lapply(out, head)
#' @keywords internal
#' @noRd
.conj_bernoulli_sv <- function(s1 = NULL, priors = NULL,
                               plot = FALSE, support = NULL, cred.int.level = NULL,
                               calculatingSupport = FALSE) {
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(a = 0.5, b = 0.5)
  }
  if (!is.logical(s1)) {
    stop("Bernoulli data must be supplied as a logical vector")
  }
  #* `Update beta prior with sufficient statistics`
  a1_prime <- priors$a[1] + sum(s1)
  b1_prime <- priors$b[1] + sum(!s1)
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    return(c(0.0001, 0.9999))
  }
  out <- list()
  #* `Make Posterior Draws`
  out$posteriorDraws <- rbeta(10000, a1_prime, b1_prime)
  #* `posterior`
  dens1 <- dbeta(support, a1_prime, b1_prime)
  pdf1 <- dens1 / sum(dens1)
  out$pdf <- pdf1
  #* `calculate highest density interval`
  hdi1 <- qbeta(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), a1_prime, b1_prime)
  #* `calculate highest density estimate``
  hde1 <- .betaHDE(a1_prime, b1_prime)
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior <- list("a" = a1_prime, "b" = b1_prime)
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' Visualizing igraph networks
#'
#' @description Easy igraph visualization with pcv.net output
#'
#'
#' @param net Network object similar to that returned from pcv.net, having dataframes named "edges"
#' and "nodes"
#' @param fill Variable name(s) from the nodes data to be used to color points. By default "strength"
#' is used.
#' @param shape Optional discrete variable name(s) from the nodes data to be used to change the shape
#' of points. If this variable is numeric it will be coerced to character.
#' @param size Size of points, defaults to 3.
#' @param edgeWeight Edge dataframe column to weight connections between nodes. Defaults to "emd"
#' for compatability with \code{pcv.emd}.
#' @param edgeFilter How should edges be filtered? This can be either a numeric (0.5)
#' in which case it is taken as a filter where only edges with values greater than or equal to
#' that number are kept or a character string ("0.5") in which case the strongest
#' X percentage of edges are kept. This defaults to NULL which does no filtering,
#' although that should not be considered the best standard behaviour. See details.
#' @import ggplot2
#' @importFrom stats quantile
#'
#' @keywords emd network
#' @examples
#'
#' library(extraDistr)
#' dists <- list(
#'   rmixnorm = list(mean = c(70, 150), sd = c(15, 5), alpha = c(0.3, 0.7)),
#'   rnorm = list(mean = 90, sd = 3)
#' )
#' x <- mvSim(
#'   dists = dists, n_samples = 5, counts = 1000,
#'   min_bin = 1, max_bin = 180, wide = TRUE
#' )
#' emd_df <- pcv.emd(x,
#'   cols = "sim", reorder = c("group"), mat = FALSE,
#'   plot = FALSE, parallel = 1
#' )
#' net <- pcv.net(emd_df, meta = "group")
#' net.plot(net)
#' net.plot(net, edgeFilter = "0.25")
#' net.plot(net,
#'   edgeFilter = 0.25, fill = c("degree", "group"),
#'   shape = c("degree", "group")
#' )
#' net.plot(net,
#'   edgeFilter = 0.25, fill = c("degree", "group"),
#'   shape = c("degree")
#' )
#'
#' @return Returns a ggplot of a network.
#'
#' @export
#'

net.plot <- function(net, fill = "strength", shape = NULL, size = 3, edgeWeight = "emd",
                     edgeFilter = NULL) {
  nodes <- net[["nodes"]]
  edges <- net[["edges"]]
  if (is.null(fill)) {
    fill <- "NOFILL"
    nodes$NOFILL <- "a"
  }
  if (length(fill) > 1) {
    nodes$FILL <- interaction(nodes[, fill])
    fill <- "FILL"
  }
  if (is.null(shape)) {
    shape <- "NOSHAPE"
    nodes$NOSHAPE <- "a"
  }
  if (length(shape) > 1) {
    nodes$SHAPE <- interaction(nodes[, shape])
    shape <- "SHAPE"
  }
  if (is.numeric(nodes[[shape]])) {
    nodes[[shape]] <- as.character(nodes[[shape]])
  }
  if (!is.null(edgeFilter)) {
    if (is.character(edgeFilter)) {
      cutoff <- quantile(edges[[edgeWeight]], probs = as.numeric(edgeFilter))
      edges <- edges[edges[[edgeWeight]] >= as.numeric(cutoff), ]
    } else if (is.numeric(edgeFilter)) {
      edges <- edges[edges[[edgeWeight]] >= edgeFilter, ]
    }
    nodes <- nodes[nodes$index %in% c(edges$from, edges$to), ]
  }


  p <- ggplot2::ggplot(nodes) +
    ggplot2::geom_segment(data = edges, ggplot2::aes(
      x = .data$from.x, xend = .data$to.x, y = .data$from.y, yend = .data$to.y,
      linewidth = .data[[edgeWeight]]
    ), colour = "black", alpha = 0.1) +
    ggplot2::geom_point(data = nodes, size = size, ggplot2::aes(
      x = .data$V1, y = .data$V2,
      fill = .data[[fill]], color = .data[[fill]],
      shape = .data[[shape]]
    ), alpha = 1, show.legend = TRUE) +
    ggplot2::scale_linewidth(range = c(0.1, 1.5)) +
    #* note that scaling shape should work, but there is a documented ggplot2
    #* bug where this messes up the legend, so
    #* until that is fixed I will not specify fillable shapes.
    ggplot2::guides(linewidth = "none", shape = ggplot2::guide_legend(nrow = 1), fill = "none") +
    ggplot2::theme_void() +
    ggplot2::theme(legend.position = "bottom")
  if (length(fill == 1) && fill == "NOFILL") {
    p <- p + ggplot2::guides(color = "none")
  }
  if (length(shape) == 1 && shape == "NOSHAPE") {
    p <- p + ggplot2::guides(shape = "none")
  }
  return(p)
}

#' Read in lemnatech watering data from metadata.json files
#'
#' @param file Path to a json file of lemnatech metadata.
#' @param envKey Character string representing the json key for environment data.
#'  By default this is set to "environment".
#'  Currently there are no situations where this makes sense to change.
#' @keywords watering json
#' @import jsonlite
#' @importFrom utils type.convert
#' @return A data frame containing the bellwether watering data
#' @examples
#'
#' w <- bw.water("https://raw.githubusercontent.com/joshqsumner/pcvrTestData/main/metadata.json")
#'
#' @export

bw.water <- function(file = NULL, envKey = "environment") {
  meta <- jsonlite::fromJSON(txt = file)
  env <- as.data.frame(do.call(rbind, meta[[envKey]]))
  env$snapshot <- rownames(env)
  rownames(env) <- NULL
  env <- as.data.frame(apply(env, 2, as.character))
  env <- type.convert(env, as.is = TRUE)
  if ("timestamp" %in% colnames(env)) {
    tryCatch(
      {
        env$timestamp <- as.POSIXct(env$timestamp, tryFormats = c(
          "%Y-%m-%d %H:%M:%OS",
          "%Y-%m-%dT%H:%M:%OS",
          "%Y/%m/%d %H:%M:%OS",
          "%Y-%m-%d %H:%M",
          "%Y/%m/%d %H:%M",
          "%Y-%m-%d",
          "%Y/%m/%d"
        ), tz = "UTC")
        begin <- min(env$timestamp, na.rm = TRUE)
        message(paste0(
          "Using the first watering time, ", begin,
          ", as beginning of experiment to assign DAS"
        ))
        env$DAS <- as.numeric((env$timestamp - begin) / 24 / 60 / 60)
      },
      error = function(err) {},
      warning = function(warn) {}
    )
  }
  return(env)
}

#' Calculate relative tolerance of some phenotype(s) relative to control
#'
#' @description Often in bellwether experiments we are curious about the effect of some
#' treatment vs control. For certain routes in analysing the data this requires considering
#' phenotypes as relative differences compared to a control. Note that the \code{conjugate}
#' function can also be useful in considering the relative tolerance to stress between groups and that
#' growth models are another suggested way to test relative tolerance questions.
#'
#' @param df Dataframe to use, this can be in long or wide format.
#' @param phenotypes A character vector of column names for the phenotypes
#'     that should be compared against control.
#' @param grouping A character vector of column names that identify groups in the data.
#'    These groups will be calibrated separately,
#'    with the exception of the group that identifies a control within the greater hierarchy.
#'    Note that for levels of grouping where the control group does not exist the output will be NA.
#' @param control A column name for the variable to be used to select the control observations.
#'     If left NULL (the default) then this will be taken as the first string in the group argument.
#' @param controlGroup The level of the control variable to compare groups against.
#' @param traitCol Column with phenotype names, defaults to "trait".
#'    This should generally not need to be changed from the default.
#'    If this and valueCol are present in colnames(df) then the data
#'    is assumed to be in long format.
#' @param valueCol Column with phenotype values, defaults to "value".
#'    This should generally not need to be changed from the default.
#' @return A dataframe with relative tolerance columns added.
#' @importFrom stats sd setNames
#' @keywords single-value-trait
#' @examples
#' \donttest{
#' sv <- read.pcv(
#'   "https://raw.githubusercontent.com/joshqsumner/pcvrTestData/main/pcv4-single-value-traits.csv",
#'   reader = "fread"
#' )
#' sv$genotype <- substr(sv$barcode, 3, 5)
#' sv$genotype <- ifelse(sv$genotype == "002", "B73",
#'   ifelse(sv$genotype == "003", "W605S",
#'     ifelse(sv$genotype == "004", "MM", "Mo17")
#'   )
#' )
#' sv$fertilizer <- substr(sv$barcode, 8, 8)
#' sv$fertilizer <- ifelse(sv$fertilizer == "A", "100",
#'   ifelse(sv$fertilizer == "B", "50", "0")
#' )
#'
#' sv <- bw.time(sv,
#'   plantingDelay = 0, phenotype = "area_pixels",
#'   cutoff = 10, timeCol = "timestamp", group = c("barcode", "rotation"), plot = FALSE
#' )
#' phenotypes <- colnames(sv)[19:35]
#' phenoForm <- paste0("cbind(", paste0(phenotypes, collapse = ", "), ")")
#' groupForm <- "DAS+DAP+barcode+genotype+fertilizer"
#' form <- as.formula(paste0(phenoForm, "~", groupForm))
#' sv <- aggregate(form, data = sv, mean, na.rm = TRUE)
#' sv <- bw.outliers(sv,
#'   phenotype = "area_pixels",
#'   group = c("DAS", "genotype", "fertilizer"),
#'   plotgroup = c("barcode")
#' )$data
#'
#' pixels_per_cmsq <- 42.5^2 # pixel per cm^2
#' sv$area_cm2 <- sv$area_pixels / pixels_per_cmsq
#' sv$height_cm <- sv$height_pixels / 42.5
#'
#' df <- sv
#' phenotypes <- c("area_cm2", "height_cm")
#' grouping <- c("fertilizer", "genotype", "DAS")
#' controlGroup <- "100"
#' control <- "fertilizer"
#'
#' rt <- relativeTolerance(df, phenotypes, grouping, control, controlGroup)
#' head(rt)
#' sapply(rt, function(c) sum(is.na(c)))
#' }
#'
#' @export
#'
relativeTolerance <- function(df, phenotypes = NULL, grouping = NULL, control = NULL,
                              controlGroup = NULL, traitCol = "trait", valueCol = "value") {
  if (all(c(traitCol, valueCol) %in% colnames(df))) {
    wide <- FALSE
  } else {
    wide <- TRUE
  }
  if (is.null(grouping)) {
    grouping <- control
  }
  if (is.null(control)) {
    control <- grouping[1]
  }
  if (is.null(controlGroup)) {
    controlGroup <- unique(df[[control]])[1]
  }

  if (control %in% grouping) {
    group_no_control <- grouping[grouping != control]
  } else {
    group_no_control <- grouping
  }
  group_no_control_factor <- interaction(df[, group_no_control])
  datsp <- split(x = df, f = group_no_control_factor)

  #* if Z = x/y
  #* x ~ N(mu_1, sd_1)
  #* y ~ N(mu_2, sd_2)
  #* mu_z = mu_1/mu_2
  #* sd_z = sqrt( ((sd_1 / mu_1)^2) + ((sd_2/mu_2)^2) ) * mu_1/mu_2

  #* `Wide`
  if (wide) {
    d2 <- do.call(rbind, lapply(datsp, function(d) {
      d_res <- do.call(rbind, lapply(phenotypes, function(pheno) {
        ctrl_mean <- mean(d[d[[control]] == controlGroup, pheno])
        ctrl_se <- sd(d[d[[control]] == controlGroup, pheno]) /
          length(d[d[[control]] == controlGroup, pheno])
        pheno_res <- do.call(rbind, lapply(setdiff(unique(d[[control]]), controlGroup), function(cg) {
          #* experimental group parameters
          mu_eg <- mean(d[d[[control]] == cg, pheno])
          se_eg <- sd(d[d[[control]] == cg, pheno]) / length(d[d[[control]] == cg, pheno])
          #* relative center and propogated error
          mu_rel <- mu_eg / ctrl_mean
          se_rel <- sqrt(((se_eg / mu_eg)^2) + ((ctrl_se / ctrl_mean)^2)) * mu_rel
          setNames(
            data.frame(
              cg, d[1, group_no_control], pheno, mu_rel, se_rel,
              mu_eg, se_eg, ctrl_mean, ctrl_se
            ),
            c(
              control, group_no_control, "phenotype", "mu_rel", "se_rel",
              "mu_trt", "se_trt", "mu_control", "se_control"
            )
          )
        }))
        pheno_res
      }))
      d_res
    }))
    rownames(d2) <- NULL
  } else { #* `Long`
    d2 <- do.call(rbind, lapply(datsp, function(d) {
      d_res <- do.call(rbind, lapply(phenotypes, function(pheno) {
        ctrl_mean <- mean(d[d[[control]] == controlGroup & d[[traitCol]] == pheno, valueCol])
        ctrl_se <- sd(d[d[[control]] == controlGroup & d[[traitCol]] == pheno, valueCol]) /
          length(d[d[[control]] == controlGroup & d[[traitCol]] == pheno, valueCol])
        pheno_res <- do.call(rbind, lapply(setdiff(unique(d[[control]]), controlGroup), function(cg) {
          #* experimental group parameters
          mu_eg <- mean(d[d[[control]] == cg & d[[traitCol]] == pheno, valueCol])
          se_eg <- sd(d[d[[control]] == cg, pheno]) /
            length(d[d[[control]] == cg & d[[traitCol]] == pheno, valueCol])
          #* relative center and propogated error
          mu_rel <- mu_eg / ctrl_mean
          se_rel <- sqrt(((se_eg / mu_eg)^2) + ((ctrl_se / ctrl_mean)^2)) * mu_rel
          setNames(
            data.frame(
              cg, d[1, group_no_control], pheno, mu_rel, se_rel,
              mu_eg, se_eg, ctrl_mean, ctrl_se
            ),
            c(
              control, group_no_control, "phenotype", "mu_rel", "se_rel",
              "mu_trt", "se_trt", "mu_control", "se_control"
            )
          )
        }))
        pheno_res
      }))
      d_res
    }))
    rownames(d2) <- NULL
  }
  return(d2)
}

#' Function to visualize \code{survival::survreg} models fit by \code{fitGrowth}.
#'
#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
#' (and similar models made through other means) can be visualized easily using this function.
#' This will generally be called by \code{growthPlot}.
#'
#' @param fit A model fit returned by \code{fitGrowth} with type="nls".
#' @param form A formula similar to that in \code{growthSS} inputs (or the \code{pcvrForm}
#' part of the output) specifying the outcome,
#' predictor, and grouping structure of the data as \code{outcome ~ predictor|individual/group}.
#' If the individual and group are specified then the observed growth lines are plotted.
#' @param groups An optional set of groups to keep in the plot.
#' Defaults to NULL in which case all groups in the model are plotted.
#' @param df A dataframe to use in plotting observed growth curves on top of the model.
#' This must be supplied for nls models.
#' @param timeRange Ignored, included for compatibility with other plotting functions.
#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
#' @param groupFill logical, should groups have different colors? Defaults to FALSE.
#' If TRUE then viridis colormaps are used in the order of virMaps
#' @param virMaps order of viridis maps to use. Will be recycled to necessary length. Defaults to
#' "plasma", but will generally be informed by growthPlot's default.
#' @keywords survival
#' @importFrom methods is
#' @import ggplot2
#' @importFrom stats predict
#' @examples
#'
#'
#' df <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "survival weibull", form = y > 100 ~ time | id / group,
#'   df = df, type = "survreg"
#' )
#' fit <- fitGrowth(ss)
#' survregPlot(fit, form = ss$pcvrForm, df = ss$df)
#' survregPlot(fit, form = ss$pcvrForm, df = ss$df, groups = "a")
#' survregPlot(fit,
#'   form = ss$pcvrForm, df = ss$df, facetGroups = FALSE,
#'   groupFill = TRUE, virMaps = c("plasma", "mako")
#' )
#'
#' @return Returns a ggplot showing an survival model's survival function.
#'
#' @export

survregPlot <- function(fit, form, groups = NULL, df = NULL, timeRange = NULL, facetGroups = TRUE,
                        groupFill = FALSE, virMaps = c("plasma")) {
  #* `parse formula`
  parsed_form <- .parsePcvrForm(form, df)
  x <- parsed_form$x
  group <- parsed_form$group
  df <- parsed_form$data
  #* `filter by groups if groups != NULL`
  if (!is.null(groups)) {
    df <- df[df[[group]] %in% groups, ]
  } else {
    groups <- unique(df[[group]])
  }
  #* `generate predictions`
  pct <- seq(0.01, 0.99, 0.01)
  preds <- predict(fit,
    newdata = data.frame("group" = groups),
    type = "quantile", p = pct, se.fit = TRUE
  )
  preds <- lapply(preds, function(d) {
    matrix(d, nrow = length(groups), ncol = length(pct))
  })
  pred_df <- stats::setNames(as.data.frame(t(preds$fit)), c(paste0("est_", groups)))
  pred_df <- cbind(pred_df, stats::setNames(as.data.frame(t(preds$se.fit)), c(paste0("se_", groups))))
  pred_df$pct <- 1 - pct
  dt <- data.table::as.data.table(pred_df)
  dt_long <- data.table::melt(dt, id.vars = "pct")
  dt_long$group <- gsub(".*_", "", dt_long$variable)
  dt_long$variable <- gsub("_.*", "", dt_long$variable)
  preds <- data.frame(data.table::dcast(dt_long, pct + group ~ variable, value.var = "value"))
  #* `facetGroups`
  if (facetGroups) {
    facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
  } else {
    facet_layer <- NULL
  }
  #* `groupFill`
  if (groupFill) {
    virVals <- lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
      viridis::viridis(3, begin = 0.1, option = pal)
    })
    names(virVals) <- groups
    color_scale <- ggplot2::scale_color_manual(values = unlist(lapply(virVals, function(pal) pal[3])))
  } else {
    virVals <- lapply(rep("plasma", length.out = length(unique(df[[group]]))), function(pal) {
      viridis::viridis(3, begin = 0.1, option = pal)
    })
    names(virVals) <- groups
    color_scale <- ggplot2::scale_color_manual(values = unlist(lapply(virVals, function(pal) pal[3])))
  }
  #* `Make ggplot`
  p <- ggplot2::ggplot(preds, ggplot2::aes(
    x = .data[["est"]],
    y = .data[["pct"]], group = .data[[group]]
  )) +
    facet_layer +
    lapply(groups, function(grp) {
      ggplot2::geom_ribbon(data = preds[preds[[group]] == grp, ], ggplot2::aes(
        xmin = .data[["est"]] - (2 * .data[["se"]]),
        xmax = .data[["est"]] + (2 * .data[["se"]])
      ), fill = virVals[[grp]][1], alpha = 0.5)
    }) +
    lapply(groups, function(grp) {
      ggplot2::geom_ribbon(data = preds[preds[[group]] == grp, ], ggplot2::aes(
        xmin = .data[["est"]] - (1 * .data[["se"]]),
        xmax = .data[["est"]] + (1 * .data[["se"]])
      ), fill = virVals[[grp]][2], alpha = 0.5)
    }) +
    ggplot2::geom_line(ggplot2::aes(color = .data[[group]]), show.legend = FALSE) +
    color_scale +
    ggplot2::scale_y_continuous(labels = scales::label_percent()) +
    ggplot2::labs(x = x, y = "Survival") +
    pcv_theme()
  #* `Add data as KM line`
  if (!is.null(df)) {
    km_df <- do.call(rbind, lapply(groups, function(grp) {
      sub <- df[df[[group]] == grp, ]
      do.call(rbind, lapply(seq(0, max(df[[x]]), 1), function(ti) {
        sum_events <- sum(c(sub[as.numeric(sub[[x]]) <= ti, "event"], 0))
        n_at_risk <- nrow(sub) - sum_events
        surv_pct <- n_at_risk / nrow(sub)
        iter <- data.frame(
          group = grp, time = ti, events = sum_events,
          at_risk = n_at_risk, surv_pct = surv_pct
        )
        colnames(iter)[1] <- group
        iter
      }))
    }))
    p <- p + ggplot2::geom_line(data = km_df, ggplot2::aes(
      x = .data[[x]],
      y = .data[["surv_pct"]],
      group = .data[[group]],
      linetype = .data[[group]]
    ), color = "black", show.legend = FALSE)
  }


  return(p)
}

#' @description
#' Negative binomial via conjugate beta prior GIVEN A KNOWN R
#' conjugacy:
#' if counts ~ nbinom(n, r)
#' where n is the number of successful trials
#'   and r is the prob of success per trial which is fixed and known
#'
#' if r is known then p ~ beta(A, B)
#' note that the compendium of conjugate priors seems to have a typo for this relationship,
#' but the wikipedia conjugate prior article is correct
#' \code{A' = A + r*n}
#' \code{B' = B + sum(X)}
#'
#' Using MoM:
#'
#' \bar{x} = k(1-p)/p
#' s^2 = \bar{x}/p
#' r = \bar{x}^2 / (s^2 - \bar{x})
#' p = \bar{x}/s^2
#'
#' @param s1 A vector of numerics drawn from a negative binomial distribution.
#' @examples
#' .conj_negbin_sv(
#'   s1 = rnbinom(10, 10, 0.5),
#'   priors = NULL,
#'   plot = FALSE,
#'   cred.int.level = 0.89
#' )
#' @keywords internal
#' @noRd

.conj_negbin_sv <- function(s1 = NULL, priors = NULL,
                            plot = FALSE, support = NULL, cred.int.level = NULL,
                            calculatingSupport = FALSE) {
  #* `Check samples`
  if (any(abs(s1 - round(s1)) > .Machine$double.eps^0.5) || any(s1 < 0)) {
    stop("Only positive whole numbers can be used in the Negative Binomial distribution")
  }
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(r = 10, a = 0.5, b = 0.5) # beta prior on P
    warning(paste0(
      "True value of r for negative binomial distribution has defaulted to 10,",
      " you should add a prior including r parameter."
    ))
  }

  out <- list()

  #* `Use conjugate beta prior on probability`
  #* Note that this is very sensitive to the R value being appropriate
  a1_prime <- priors$a[1] + priors$r[1] * length(s1)
  b1_prime <- priors$b[1] + sum(s1)
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    return(c(0.0001, 0.9999))
  }
  #* `calculate density over support``
  dens1 <- dbeta(support, a1_prime, b1_prime)
  pdf1 <- dens1 / sum(dens1)

  #* `calculate highest density interval`
  hdi1 <- qbeta(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), a1_prime, b1_prime)

  #* `calculate highest density estimate``
  hde1 <- .betaHDE(a1_prime, b1_prime)

  #* `save summary and parameters`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior$r <- priors$r[1]
  out$posterior$a <- a1_prime
  out$posterior$b <- b1_prime
  #* `Make Posterior Draws`
  out$posteriorDraws <- rbeta(10000, a1_prime, b1_prime)
  out$pdf <- pdf1
  #* `keep data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support, "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' Ease of use growth model helper function.
#'
#' Output from this should be passed to \link{fitGrowth} to fit the specified model.
#'
#' @param model The name of a model as a character string.
#'  Supported options are c("logistic", "gompertz", "weibull", "frechet", "gumbel", "monomolecular",
#'  "exponential", "linear", "power law", "bragg", "lorentz", "beta",
#'  "double logistic", "double gompertz", "gam", "int"), with "int" representing an intercept only model
#'  which is only used in brms (and is expected to only be used in threshold models or to model
#'  homoskedasticity). Note that the dose response curves (bragg, lorentz, and beta) may be difficult
#'  to fit using the \code{nlme} backend but should work well using other options.
#'  See \code{\link{growthSim}} for examples of each type of single parameterized growth curve
#'  ("gam" is not supported in \code{growthSim}).
#'  You can also specify decay models by including the "decay" keyword with the model name. Note that
#'  using "decay" is only necessary for the brms backend since otherwise the priors are strictly
#'  positive.
#'  In brms models the entire formula is negated for decay models so that lognormal priors can
#'  still be used when at least some coefficients would be negative.
#'  Additionally, the "int_" prefix may be added to a model name to specify that an intercept should
#'  be included. By default these models are assumed to have intercepts at 0, which is often fine.
#'  If you include an intercept in a brms model then you would specify the prior as you would for an
#'  "A", "B", or "C" parameter but as "I". By default growthSS will make student T priors for intercept
#'  parameters in the same way that it will for estimated changepoints (see below).
#'  With type="brms" you can also specify segmented models by combining model names with a plus sign
#'  such as "linear + linear". In a segmented model the names for parameters do not follow the normal
#'  "A", "B", "C" notation, instead they are named for the type of model, the position in the formula,
#'  then for the parameter of that model. There will also be parameters to represent the time when
#'  growth switches from one model to another called either "changepointX" or "fixedChangePointX".
#'  All "changePointX" terms are estimated as parameters of the model.
#'  "fixedChangePointX" parameters are not estimated and are kept as the numeric value given in the
#'  priors, this is useful if your experiment has an intervention at a set time which you expect to
#'  change the growth process acutely.
#'  For the "linear + linear" example this would yield parameters "linear1A", "changePoint1"
#'  (or "fixedChangePoint1"), and "linear2A". A "linear + gompertz" model would have
#'  "linear1A", "changePoint1", "gompertz2A", "gompertz2B", and "gompertz2C" for parameters.
#'  Note that double sigmoid models are not supported as parts of segmented models and gams
#'  can currently only be included as the last part of a segmented model. When using a changepoint model
#'  it may be worth using segments that are simpler to fit
#'  (gompertz instead of EVD options, for instance). Currently "homo" and "int" are treated the same
#'  and "spline" and "gam" are interchangeable. Time-to-event models can be specified using the
#'  "survival" keyword, see details for an explanation of the changes that entails.
#'  Similarly, using the brms backend response distributions (see \code{brms::brmsfamily})
#'  can be specified in the model as "family: model" so that a model
#'  of logistic increasing counts may be written as \code{model = "poisson: logistic"}.
#' @param form A formula describing the model. The left hand side should only be
#' the outcome variable (phenotype), and a cutoff if you are making a survival model (see details).
#' The right hand side needs at least the x variable
#'  (typically time). Grouping is also described in this formula using roughly lme4
#'  style syntax,with formulas like \code{y~time|individual/group} to show that predictors
#'  should vary by \code{group} and autocorrelation between \code{individual:group}
#'  interactions should be modeled. Note that autocorrelation is only modeled with the "brms"
#'  backend in this way. "nlme" requires random effects and correlations to use the same grouping,
#'  so autocorrelation using the "nlme" backend works at the group level, so will slightly underestimate
#'  the autocorrelation at the individual level. If group has only one level or is not included then
#'  it will be ignored in formulas for growth and variance (this may be the case if
#'  you split data before fitting models to be able to run more smaller models each more quickly).
#'  Hierarchical models can be specified for the brms backend as
#'  \code{y~time+other_covariate|individual/group} in which case the parameters of the main growth model
#'  will themselves be estimated by models as specified in the \code{hierarchy} argument. For instance,
#'  if normally "A" had an intercept for each \code{group}, now it would be predicted as
#'  \code{A ~ AI + AA * covariate} where AI and AA now have an intercept for each \code{group}.
#' @param sigma Other models for distributional parameters.
#' This argument is only used with "brms" and "nlme" models and is handled differently for each.
#' When type="brms" this can be supplied as a model or as a list of models.
#' It is turned into a formula (or list of formulas) with an entry corresponding to each distributional
#' parameter (after the mean) of the growth model family.
#' If no family was specified (\code{model="logistic"} for instance) then the student T distribution
#' is used, with additional distributional parameters sigma and nu.
#' To check the naming of distributional parameters in each response family use
#' \code{brms::brmsfamily("family")$dpars}. The supported options are the same as the model options
#' (including threshold models).
#' For distributional parameters that do not have a formula specified they will be modeled as
#' intercept only (not by group).
#' Parameter names are the same as those in the main model but with the distributional parameter name
#' as a prefix. Additionally, if a linear model is used for sigma then it can be modeled with or without
#' a prior, if a prior is specified ("sigmaA") then a non-linear formula is used and the "sigmaA"
#' parameter will be included in the output instead of the default "sigma" term.
#' In the rare case that you wish to model the mean and the 3rd distributional parameter but not
#' the 2nd then \code{sigma = list("not_estimated", "model")} would allow for that.
#'  When type ="nlme" the options are more limited to c("none", "power", "exp"), corresponding to using
#' \code{nlme::varIdent}, \code{nlme::varPower}, or \code{nlme::varExp} respectively where "power"
#' is the default.
#' @param df A dataframe to use. Must contain all the variables listed in the formula.
#' @param pars Optionally specify which parameters should change by group. Not this is model
#' dependent and is not implemented for brms models due to their more flexible hypothesis testing.
#' @param start An optional named list of starting values OR means for prior distributions.
#' If this is not provided then starting values are picked with \code{stats::selfStart}.
#'  When type = "brms" these should be provided and are treated as the means of
#'   lognormal priors for all growth model parameters and T_5(mu, 3) priors for changepoint parameters.
#'   This is done because the values are strictly positive and the lognormal distribution
#'   is easily interpreted. The changepoint priors are T distributions for symmetry, 5 DF
#'   having been chosen for heavy but not unmanageable tails.
#'   If this argument is not provided then priors are made using brms::get_prior.
#'   Those priors are unlikely to be suitable and a different set of priors will need to be made
#'   for the model using \code{brms::set_prior} for good convergence. When specifying starting
#'   values/prior means think of this as being similar to the \code{params} argument
#'   in \code{growthSim}. Names should correspond to parameter names from the
#'   \code{model} argument. A numeric vector can also be used, but specifying
#'   names is best practice for clarity. Additionally, due to a limitation in
#'   \code{brms} currently lower bounds cannot be set for priors for specific groups.
#'   If priors include multiple groups (\code{start = list(A = c(10,15), ...)}) then
#'   you will see warnings after the model is fit about not having specified a lower
#'   bound explicitly. Those warnings can safely be ignored and will be addressed if
#'   the necessary features are added to \code{brms}. See details for guidance.
#' @param type Type of model to fit, options are "brms", "nlrq", "nlme", "nls", and "mgcv".
#' Note that the "mgcv" option only supports "gam" models.
#' Survival models can use the "survreg" model type
#' (this will be called if any non-brms/flexsurv type is given) or the "flexsurv" model type
#' which requires the flexsurv package to be installed.
#' Note that for non-brms models variables in the model will be labeled by the factor level of the
#' group, not necessarily by the group name.
#' This is done for ease of use with different modeling functions, the levels are alphabetically sorted
#' and can be checked using:
#' \code{table(ss$df$group, ss$df$group_numericLabel)}.
#' @param tau A vector of quantiles to fit for nlrq models.
#' @param hierarchy Optionally a list of model parameters that should themselves by modeled by another
#' predictor variable. This is only used with the brms backend.
#' @keywords Bayesian brms nls nlme nlrq mgcv longitudinal
#'
#' @importFrom stats as.formula rgamma
#'
#' @details
#'
#' Default priors are not provided, but these can serve as starting points for each distribution.
#' You are encouraged to use \code{growthSim} to consider what kind
#' of trendlines result from changes to your prior and for interpretation of each parameter.
#' The \link{plotPrior} function can be used to do prior predictive checks.
#' You should not looking back and forth at your data trying to match your
#'  observed growth exactly with a prior distribution,
#' rather this should be informed by an understanding of the plants you
#'  are using and expectations based on previous research.
#'  For the "double" models the parameter interpretation is the same
#'  as for their non-double counterparts except that there are A and A2, etc.
#'  It is strongly recommended to familiarize yourself with the double sigmoid
#'  distributions using growthSim before attempting to model one. Additionally,
#'  those distributions are intended for use with long delays in an experiment,
#'  think stress recovery experiments, not for minor hiccups in plant growth.
#'
#' \itemize{
#'    \item \bold{Logistic}: \code{list('A' = 130, 'B' = 12, 'C' = 3)}
#'     \item \bold{Gompertz}: \code{list('A' = 130, 'B' = 12, 'C' = 1.25)}
#'     \item \bold{Weibull}: \code{list('A' = 130, 'B' = 2, 'C' = 2)}
#'     \item \bold{Frechet}: \code{list('A' = 130, 'B' = 5, 'C' = 6)}
#'     \item \bold{Gumbel}: \code{list('A' = 130, 'B' = 6, 'C' = 4)}
#'     \item \bold{Double Logistic}: \code{list('A' = 130, 'B' = 12, 'C' = 3,
#'     'A2' = 200, 'B2' = 25, 'C2' = 1)}
#'     \item \bold{Double Gompertz}: \code{list('A' = 130, 'B' = 12, 'C' = 0.25,
#'     'A2' = 220, 'B2' = 30, 'C2' = 0.1)}
#'     \item \bold{Monomolecular}: \code{list('A' = 130, 'B' = 2)}
#'     \item \bold{Exponential}: \code{list('A' = 15, 'B' = 0.1)}
#'     \item \bold{Linear}: \code{list('A' = 1)}
#'     \item \bold{Power Law}: \code{list('A' = 13, 'B' = 2)}
#' }
#'
#' See details below about parameterization for each model option.
#' \itemize{
#'  \item \bold{Logistic}: `A / (1 + exp( (B-x)/C) )`
#'  Where A is the asymptote, B is the inflection point, C is the growth rate.
#'  \item \bold{Gompertz}: `A * exp(-B * exp(-C*x))`
#'  Where A is the asymptote, B is the inflection point, C is the growth rate.
#'  \item \bold{Weibull}: `A * (1-exp(-(x/C)^B))`
#'  Where A is the asymptote, B is the weibull shape parameter, C is the weibull scale parameter.
#'  \item \bold{Frechet}: `A * exp(-((x-0)/C)^(-B))`
#'  Where A is the asymptote, B is the frechet shape parameter, C is the frechet scale parameter.
#'  Note that the location parameter (conventionally m) is 0 in these models for simplicity but is still
#'  included in the formula.
#'  \item \bold{Gumbel}: `A * exp(-exp(-(x-B)/C))`
#'  Where A is the asymptote, B is the inflection point (location), C is the growth rate (scale).
#'  \item \bold{Double Logistic}: `A / (1+exp((B-x)/C)) + ((A2-A) /(1+exp((B2-x)/C2)))`
#'  Where A is the asymptote, B is the inflection point, C is the growth rate,
#'  A2 is the second asymptote, B2 is the second inflection point, and C2 is the second
#'  growth rate.
#'  \item \bold{Double Gompertz}: `A * exp(-B * exp(-C*x)) + ((A2-A) * exp(-B2 * exp(-C2*(x-B))))`
#'  Where A is the asymptote, B is the inflection point, C is the growth rate,
#'  A2 is the second asymptote, B2 is the second inflection point, and C2 is the second
#'  growth rate.
#'  \item \bold{Monomolecular}: `A-A * exp(-B * x)`
#'  Where A is the asymptote and B is the growth rate.
#'  \item \bold{Exponential}: `A * exp(B * x)`
#'  Where A is the scale parameter and B is the growth rate.
#'  \item \bold{Linear}: `A * x`
#'  Where A is the growth rate.
#'  \item \bold{Power Law}: `A * x^(B)`
#'  Where A is the scale parameter and B is the growth rate.
#'  \item \bold{Bragg}: `A * exp(-B * (x - C) ^ 2)`
#'  This models minima and maxima as a dose-response curve where A is the max response,
#'  B is the "precision" or slope at inflection, and C is the x position of the max response.
#'  \item \bold{Lorentz}: `A / (1 + B * (x - C) ^ 2)`
#'  This models minima and maxima as a dose-response curve where A is the max response,
#'  B is the "precision" or slope at inflection, and C is the x position of the max response.
#'  Generally Bragg is preferred to Lorentz for dose-response curves.
#'  \item \bold{Beta}: `A * (((x - D) / (C - D)) * ((E - x) / (E - C)) ^ ((E - C) / (C - D))) ^ B`
#'  This models minima and maxima as a dose-response curve where A is the Maximum Value,
#'  B is a shape/concavity exponent similar to the sum of alpha and beta in a Beta distribution,
#'  C is the position of maximum value, D is the minimum position where distribution > 0,
#'  E is the maximum position where distribution > 0.
#'  This is a difficult model to fit but can model non-symmetric dose-response relationships which
#'  may sometimes be worth the extra effort.
#'  }
#'  Note that for these distributions parameters do not exist in a vacuum.
#'  Changing one will make the others look different in the resulting data.
#'  The \code{growthSim} function can be helpful in familiarizing further with these distributions.
#'
#' Using the \code{brms} backend the \code{sigma} argument optionally specifies a sub model to account
#' for heteroskedasticity.
#' Any combination of models (except for decay models) can be specified in the \code{sigma} term.
#' If you need variance to raise and lower then a gam/spline is the most appropriate option.
#'
#' Using the \code{brms} backend a model with lots of parameters may be difficult to estimate if there
#' are lots of groups.
#' If you have very many levels of your "group" variable in a complex model then consider fitting models
#' to subsets of the "group" variable and using \link{combineDraws} to make a data.frame for
#' hypothesis testing.
#'
#' Limits on the Y variable can be specified in the \code{brms} backend. This should generally be
#' unnecessary and will make the model slower to fit and potentially more difficult to set priors on.
#' If you do have a limited phenotype (besides the normal positive constraint for growth models)
#' then this may be helpful, one situation may be canopy coverage percentage which is naturally bounded
#' at an upper and lower limit.
#' To specify these limits add square brackets to the Y term with upper and lower limits such as
#' \code{"y[0,100] ~ time|id/group"}. Other "Additional response information" such as resp_weights or
#' standard errors can be specified using the \code{brms} backend, with those options documented fully
#' in the \code{brms::brmsformula} details.
#'
#' There are also three supported submodel options for \code{nlme} models, but a \code{varFunc} object
#' can also be supplied, see \code{?nlme::varClasses}.
#'
#' \itemize{
#'    \item \bold{none}: \code{varIdent(1|group)}, which models a constant variance separately for each
#'    group.
#'     \item \bold{power}: \code{varPower(x|group)}, which models variance as a power of x per group.
#'     \item \bold{exp}: \code{varExp(x|group)}, which models variance as an exponent of x per group.
#' }
#'
#' Survival models can be fit using the "survival" keyword in the model specification.
#' Using the "brms" backend (type argument) you can specify "weibull" (the default) or "binomial" for
#' the distribution to use in that model so that the final model string would be "survival binomial" or
#' "survival weibull" which is equivalent to "survival". Time to event data is very different than
#' standard phenotype data, so the formula argument should include a cutoff for the Y variable to count
#' as an "event". For example, if you were checking germination using area and wanted to use 50 pixels
#' as a germinated plant your formula would be \code{area > 50 ~ time|id/group}.
#' Internally the input dataframe will be converted to time-to-event data based on that formula.
#' Alternatively you can make your own time to event data and supply that to growthSS. In that case your
#' data should have columns called "n_events"
#' (number of individuals experiencing the event at this time) and "n_eligible"
#' (number of individuals who had not experienced the event at least up to this time)
#' for the binomial model family OR "event" (binary 1,0 for TRUE, FALSE) for the Weibull model family.
#' Note that since these are linear models using different model families the priors are handled
#' differently. For survival models the default priors are weak regularizing priors (Normal(0,5))
#' on all parameters. If you wish to specify your own priors you can supply them as brmsprior objects
#' or as a list such as \code{priors = list("group1" = c(0,3), "group2" = c(0,1))} where the order of
#' values is Mu, Sigma.
#' Any non-brms backend will instead use \code{survival::survreg} to fit the model unless the
#' "flexsurv" type is specified.
#' Distributions will be passed to \code{survreg} where options are "weibull", "exponential",
#' "gaussian", "logistic","lognormal" and "loglogistic" if type = "survreg" or to
#' \code{flexsurv::flexsurvreg} if type = "flexsurv" where options are "gengamma", "gengamma.orig",
#' "genf", "genf.orig", "weibull", "gamma", "exp", "llogis", "lnorm", "gompertz", "exponential",
#' and "lognormal". In \code{flexsurvreg} distributional modeling is supported and additional
#' formula can be passed as a list to the sigma argument of growthSS in the same way as to the anc
#' argument of \code{flexsurv::flexsurvreg}.
#' Further additional arguments should be supplied via \code{fitGrowth} if desired.
#'
#'
#'
#' @return A named list of elements to make it easier to fit non linear growth models with several R
#' packages.
#'
#' For \code{brms} models the output contains:
#'
#' \code{formula}: A \code{brms::bf} formula specifying the growth model, autocorrelation,
#' variance submodel, and models for each variable in the growth model.
#' \code{prior}: A brmsprior/data.frame object.
#' \code{initfun}: A function to randomly initialize chains using a random draw from a gamma
#' distribution (confines initial values to positive and makes correct number
#' of initial values for chains and groups).
#' \code{df} The data input, with dummy variables added if needed and a column to link groups to their
#' factor levels.
#' \code{family} The model family, currently this will always be "student".
#' \code{pcvrForm} The form argument unchanged. This is returned so that
#' it can be used later on in model visualization. Often it may be a good idea
#' to save the output of this function with the fit model, so having this can
#' be useful later on.
#'
#' For \code{quantreg::nlrq} models the output contains:
#'
#' \code{formula}: An \code{nls} style formula specifying the growth model with groups if specified.
#' \code{taus}: The quantiles to be fit
#' \code{start}: The starting values, typically these will be generated from the growth model and your
#' data in a similar way as shown in \code{stats::selfStart} models.
#' \code{df} The input data for the model.
#' \code{pcvrForm} The form argument unchanged.
#'
#' For \code{nls} models the output is the same as for \code{quantreg::nlrq} models but without
#' \code{taus} returned.
#'
#' For \code{nlme::nlme} models the output contains:
#'
#' \code{formula}: An list of \code{nlme} style formulas specifying the model, fixed and random effects,
#' random effect grouping, and variance model (weights).
#' \code{start}: The starting values, typically these will be generated from the growth model and your
#' data in a similar way as shown in \code{stats::selfStart} models.
#' \code{df} The input data for the model.
#' \code{pcvrForm} The form argument unchanged.
#'
#' For all models the type and model are also returned for simplicity downstream.
#'
#' @examples
#'
#'
#' simdf <- growthSim("logistic",
#'   n = 20, t = 25,
#'   params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
#' )
#' ss <- growthSS(
#'   model = "logistic", form = y ~ time | id / group,
#'   sigma = "spline", df = simdf,
#'   start = list("A" = 130, "B" = 12, "C" = 3), type = "brms"
#' )
#' lapply(ss, class)
#' ss$initfun()
#' # the next step would typically be compiling/fitting the model
#' # here we use very few chains and very few iterations for speed, but more of both is better.
#' \donttest{
#' fit_test <- fitGrowth(ss,
#'   iter = 500, cores = 1, chains = 1, backend = "cmdstanr",
#'   control = list(adapt_delta = 0.999, max_treedepth = 20)
#' )
#' }
#'
#'
#' # formulas and priors will look different if there is only one group in the data
#'
#' ex <- growthSim("linear", n = 20, t = 25, params = list("A" = 2))
#' ex_ss <- growthSS(
#'   model = "linear", form = y ~ time | id / group, sigma = "spline",
#'   df = ex, start = list("A" = 1), type = "brms"
#' )
#'
#' ex_ss$prior # no coef level grouping for priors
#' ex_ss$formula # intercept only model for A
#'
#' ex2 <- growthSim("linear", n = 20, t = 25, params = list("A" = c(2, 2.5)))
#' ex2_ss <- growthSS(
#'   model = "linear", form = y ~ time | id / group, sigma = "spline",
#'   df = ex2, start = list("A" = 1), type = "brms"
#' )
#' ex2_ss$prior # has coef level grouping for priors
#' ex2_ss$formula # specifies an A intercept for each group and splines by group for sigma
#'
#' @export

growthSS <- function(model, form, sigma = NULL, df, start = NULL,
                     pars = NULL, type = "brms", tau = 0.5, hierarchy = NULL) {
  type_matched <- match.arg(type, choices = c(
    "brms", "nlrq", "nls",
    "nlme", "mgcv", "survreg",
    "flexsurv"
  ))
  # check for survival model
  surv <- .survModelParser(model)
  survivalBool <- surv$survival
  model <- surv$model
  # check for intercept
  int_res <- .intModelHelper(model)
  int <- int_res$int
  model <- int_res$model

  if (survivalBool) {
    if (type_matched == "brms") {
      res <- .brmsSurvSS(model = model, form = form, df = df, priors = start)
      res$type <- type_matched
    } else if (type_matched == "flexsurv") {
      res <- .flexSurvSS(model = model, form = form, df = df, anc = sigma)
      res$type <- "flexsurv"
    } else {
      res <- .survSS(model = model, form = form, df = df)
      res$type <- "survreg"
    }
  } else {
    if (type_matched == "brms") {
      res <- .brmSS(
        model = model, form = form, sigma = sigma, df = df, priors = start, int = int,
        hierarchy = hierarchy
      )
    } else if (type_matched %in% c("nlrq", "nls")) {
      res <- .nlrqSS(
        model = model, form = form, tau = tau, df = df, start = start, pars = pars,
        type = type, int = int
      )
    } else if (type_matched == "nlme") {
      if (is.null(sigma)) {
        sigma <- "power"
      }
      res <- .nlmeSS(
        model = model, form = form, sigma = sigma, df = df, pars = pars,
        start = start, int = int
      )
    } else if (type_matched == "mgcv") {
      res <- .mgcvSS(model = model, form = form, df = df)
    }
    res$type <- type
  }
  res$model <- model
  res$call <- match.call()
  return(res)
}

#' Function to parse survival model specifications in growthSS
#'
#' @param model the model specified for growthSS
#'
#' @return A list. The first component is logical whether or not the formula is a survival model.
#' Second component is the distribution to use for survival modeling (this is only used if type=="brms")
#'
#' @examples
#'
#' .survModelParser("survival - binomial")
#' .survModelParser("survival")
#' .survModelParser("logistic")
#' .survModelParser("logistic+linear")
#'
#' @keywords internal
#' @noRd

.survModelParser <- function(model) {
  distributions <- c(
    "binomial", "gengamma", "gengamma.orig", "genf", "genf.orig",
    "weibull", "gamma", "exp", "llogis", "lnorm", "gompertz",
    "exponential", "lognormal"
  )
  if (grepl("survival", model)) {
    survival <- TRUE
    model <- trimws(gsub("survival", "", model))
    if (nchar(model) == 0) {
      model <- "weibull"
    }
    dist <- match.arg(model, distributions)
    return(list("survival" = survival, "model" = dist))
  } else {
    return(list("survival" = FALSE, "model" = model))
  }
}

#' Functions to prepare several families of distributional brms models
#'
#' @param model a model passed from growthSS
#'
#' @return A list of elements to pass brmSS for fitting distributional models
#'
#' @examples
#' .brmFamilyHelper("logistic")
#' .brmFamilyHelper("poisson: logistic")
#' .brmFamilyHelper("von_mises: logistic")
#'
#' @keywords internal
#' @noRd

.brmFamilyHelper <- function(model) {
  if (!grepl("[:]", model)) {
    model <- paste0("student:", model)
  }
  dist <- trimws(gsub(":.*", "", model))
  rhs <- trimws(gsub(".*:", "", model))
  family <- dist
  dpars <- brms::brmsfamily(dist)$dpars[-1]
  return(list(family = family, dpars = dpars, rhs = rhs))
}

#' @description
#' Internal function for calculating the gamma distribution of the rate parameter in gamma distributed
#' data represented by single value traits.
#' @param s1 A vector of numerics drawn from a uniform distribution.
#' @examples
#' out <- .conj_gamma_sv(
#'   s1 = rgamma(10, 1, 2), cred.int.level = 0.95,
#'   plot = FALSE
#' )
#' lapply(out, head)
#' @keywords internal
#' @noRd
.conj_gamma_sv <- function(s1 = NULL, priors = NULL,
                           plot = FALSE, support = NULL, cred.int.level = NULL,
                           calculatingSupport = FALSE) {
  out <- list()
  #* `make default prior if none provided`
  if (is.null(priors)) {
    priors <- list(shape = 0.5, scale = 0.5, known_shape = 1)
  }
  #* `Update gamma prior with sufficient statistics`
  n <- length(s1)
  S <- sum(s1)
  shape_prime <- (priors$known_shape * n) + priors$shape
  scale_prime <- priors$scale / (1 + (priors$scale * S))
  #* `Define support if it is missing`
  if (is.null(support) && calculatingSupport) {
    quantiles <- qgamma(c(0.0001, 0.9999), shape = shape_prime, scale = scale_prime)
    return(quantiles)
  }
  #* `Make Posterior Draws`
  out$posteriorDraws <- rgamma(10000, shape = shape_prime, scale = scale_prime)
  #* `posterior`
  dens1 <- dgamma(support, shape = shape_prime, scale = scale_prime)
  pdf1 <- dens1 / sum(dens1)
  out$pdf <- pdf1
  hde1 <- .gammaHDE(shape_prime, scale_prime)
  hdi1 <- qgamma(
    c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
    shape = shape_prime, scale = scale_prime
  )
  #* `Store summary`
  out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
  out$posterior <- list(
    "shape" = shape_prime, "scale" = scale_prime,
    "known_shape" = priors$known_shape
  )
  #* `save s1 data for plotting`
  if (plot) {
    out$plot_df <- data.frame(
      "range" = support,
      "prob" = pdf1,
      "sample" = rep("Sample 1", length(support))
    )
  }
  return(out)
}

#' @description
#' Internal function for calculating the HDE of a gamma distribution
#' @param shape shape parameter
#' @param scale scale parameter
#' @examples
#' .gammaHDE(1, 2)
#' .gammaHDE(0, 1)
#' .gammaHDE(10, 10)
#' @keywords internal
#' @noRd

.gammaHDE <- function(shape, scale) {
  if (shape >= 1) {
    hde <- (shape - 1) * scale
  } else {
    hde <- 0
  }
  return(hde)
}

#' Default theme for ggplots made by pcvr functions.
#'
#' @import ggplot2
#' @importFrom ggplot2 %+replace%
#' @return A ggplot theme
#' @examples
#' ggplot2::ggplot() +
#'   pcv_theme()
#' @export
#'
pcv_theme <- function() {
  ggplot2::theme_minimal() %+replace%
    ggplot2::theme(
      axis.text.x.bottom = ggplot2::element_text(hjust = 1),
      axis.line.y.left = ggplot2::element_line(),
      axis.line.x.bottom = ggplot2::element_line(),
      strip.background = ggplot2::element_rect(fill = "gray50", color = "gray20"),
      strip.text.x = ggplot2::element_text(size = 14, color = "white"),
      strip.text.y = ggplot2::element_text(size = 14, color = "white")
    )
}

1		#' subset helper function for use reading in large data, called in pcv.sub.read
2		#'
3		#'
4		#'
5		#' @param inputFile Path to csv file of plantCV output, should be provided internally in read.pcv
6		#' @param filters filtering conditions, see read.pcv for details. Format as
7		#' list("trait in area, perimeter", "other contains stringToMatch")
8		#' @param awk Optional awk command to use instead.
9		#' @keywords read.csv pcv wide long
10		#' @details awkHelper attempts to make awk commands from human readable input.
11		#' Currently when filters are supplied the input file has quotes removed by `sed`
12		#' then is piped into awk, so an equivalent command line statement may be:
13		#' \code{sed 's/\"//g' pcvrTest2.csv \| awk -F ',' '{ if (NR==1 \|\| $18=="area") { print } }'}
14		#' @return Returns a character string representing a unix style awk statement
15		#' which is typically passed to \code{pipe} or used as a connection in \code{data.table::fread}.
16		#' @importFrom utils read.csv capture.output
17		#' @examples
18		#' link1 <- "https://gist.githubusercontent.com/seankross/"
19		#' link2 <- "a412dfbd88b3db70b74b/raw/5f23f993cd87c283ce766e7ac6b329ee7cc2e1d1/mtcars.csv"
20		#' file <- paste0(link1, link2)
21		#' awkHelper(file, list("gear in 4, 3"), awk = NULL)
22		#' awkHelper(file, "gear contains 3", awk = NULL)
23		#' # note that to be filtered the file has to exist on your local system, this example is only to show
24		#' # the output of awkHelper, which would then be executed by read.pcv
25		#' awkHelper(file, list("gear in 4, 3"), awk = "existing_command")
26		#'
27		#' @export
28		awkHelper <- function(inputFile, filters, awk = NULL) {
29	3x	if (is.null(awk)) {
30	2x	if (!is.list(filters)) {
31	1x	filters <- list(filters)
32		}
33	2x	sed <- paste0("sed 's/\"//g' ", inputFile, " \| ")
34	2x	awkStart <- "awk -F "
35	2x	awkDelim <- "',' "
36	2x	awkFiltStart <- "'{ if ("
37	2x	awkFiltEnd <- ") { print } }'"
38	2x	COLS <- colnames(read.csv(inputFile, nrows = 1))
39	2x	awkFilts <- lapply(filters, function(filt) {
40	2x	filtCol <- strsplit(filt, " ")[[1]][1]
41	2x	affector <- strsplit(filt, " ")[[1]][2]
42	2x	values <- trimws(gsub(",", " ", strsplit(filt, " ")[[1]][-c(1:2)]))
43	2x	if (affector %in% c("in", "is", "=")) {
44	1x	paste(paste0("($", which(COLS == filtCol), '=="', values, '")'), collapse = " \|\| ")
45	1x	} else if (affector == "contains") {
46	1x	valReg <- paste0(values, collapse = "\|")
47	1x	paste0("($", which(COLS == filtCol), " ~ /", valReg, "/)")
48		}
49		})
50	2x	awkFilt <- paste(paste("(", awkFilts, ")"), collapse = " && ")
51	2x	awkCommand <- capture.output(cat(sed, awkStart, awkDelim, awkFiltStart, awkFilt, awkFiltEnd))
52		} else {
53	1x	awkCommand <- awk
54		}
55	3x	return(awkCommand)
56		}

1		#' @description
2		#' Internal function for calculating \mu and \sigma of the normally distributed mean of lognormal data
3		#' given an estimate of the lognormal \sigma obtained via the method of moments using multi value
4		#' traits.
5		#' @param s1 A data.frame or matrix of multi value traits. The column names should include a number
6		#' representing the "bin".
7		#'
8		#' @examples
9		#'
10		#' mv_ln <- mvSim(
11		#' dists = list(
12		#' rlnorm = list(meanlog = log(130), sdlog = log(1.2))
13		#' ),
14		#' n_samples = 30
15		#' )
16		#' .conj_lognormal_mv(
17		#' s1 = mv_ln[1:30, -1],
18		#' priors = list(mu_log = c(log(10)), n = c(1), sigma_log = c(log(3))),
19		#' plot = FALSE, cred.int.level = 0.9
20		#' )
21		#'
22		#' @importFrom stats qnorm
23		#' @keywords internal
24		#' @noRd
25
26		.conj_lognormal_mv <- function(s1 = NULL, priors = NULL,
27		plot = FALSE, support = NULL, cred.int.level = NULL,
28		calculatingSupport = FALSE) {
29	18x	out <- list()
30		#* `make default prior if none provided`
31	18x	if (is.null(priors)) {
32	8x	priors <- list(mu = 0, sd = 5)
33		}
34		#* `Reorder columns if they are not in the numeric order`
35	18x	histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
36	18x	bins_order <- sort(histColsBin, index.return = TRUE)$ix
37	18x	s1 <- s1[, bins_order]
38
39		#* `Loop over reps, get moments for each histogram`
40
41	18x	rep_distributions <- lapply(seq_len(nrow(s1)), function(i) {
42	422x	X1 <- rep(histColsBin[bins_order], as.numeric(s1[i, ]))
43		#* `Get mean of X1`
44	422x	x_bar <- mean(X1)
45	422x	mu_x1 <- log(x_bar / (sqrt(var(X1) / x_bar^2) + 1))
46		#* `Get sigma of X1`
47	422x	sigma_x1 <- sqrt(log((var(X1)) / (x_bar^2) + 1))
48		#* `Update Normal Distribution of Mu`
49		#* sufficient stats: n, mean of log data \| precision
50	422x	n <- length(X1)
51	422x	m <- priors$mu[1]
52	422x	p <- 1 / (priors$sd[1]^2) # precision
53	422x	mu_prime <- ((m * p) + (n * p * mu_x1)) / (p + (n * p))
54	422x	precision_prime <- (p + (n * p))
55	422x	var_prime <- 1 / precision_prime
56	422x	sd_prime <- sqrt(var_prime)
57	422x	return(list("mu" = mu_prime, "sd" = sd_prime, "ln_sd" = sigma_x1))
58		})
59		#* `Unlist parameters`
60	18x	mu_ls_prime <- mean(unlist(lapply(rep_distributions, function(i) {
61	422x	i$mu
62		})))
63	18x	sigma_ls_prime <- mean(unlist(lapply(rep_distributions, function(i) {
64	422x	i$sd
65		})))
66	18x	ln_sigma_prime <- mean(unlist(lapply(rep_distributions, function(i) {
67	422x	i$ln_sd
68		})))
69
70		#* `Define support if it is missing`
71	18x	if (is.null(support) && calculatingSupport) {
72	9x	quantiles <- stats::qnorm(c(0.0001, 0.9999), mu_ls_prime, sigma_ls_prime)
73	9x	return(quantiles)
74		}
75		#* `posterior`
76	9x	dens1 <- stats::dnorm(support, mu_ls_prime, sigma_ls_prime)
77	9x	pdf1 <- dens1 / sum(dens1)
78	9x	hde1 <- mu_ls_prime
79	9x	hdi1 <- stats::qnorm(
80	9x	c(
81	9x	(1 - cred.int.level) / 2,
82	9x	(1 - ((1 - cred.int.level) / 2))
83		),
84	9x	mu_ls_prime, sigma_ls_prime
85		)
86		#* `Store summary`
87	9x	out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
88	9x	out$posterior$mu <- mu_ls_prime
89	9x	out$posterior$sd <- sigma_ls_prime
90	9x	out$posterior$lognormal_sigma <- ln_sigma_prime
91		#* `Make Posterior Draws`
92	9x	out$posteriorDraws <- stats::rnorm(10000, mu_ls_prime, sigma_ls_prime)
93	9x	out$pdf <- pdf1
94		#* `save s1 data for plotting`
95	9x	if (plot) {
96	4x	out$plot_df <- data.frame(
97	4x	"range" = support,
98	4x	"prob" = pdf1,
99	4x	"sample" = rep("Sample 1", length(support))
100		)
101		}
102	9x	return(out)
103		}
104
105
106
107		#' @description
108		#' Internal function for calculating \mu and \sigma of the normally distributed mean of lognormal data
109		#' given an estimate of the lognormal \sigma obtained via the method of moments using single value
110		#' traits.
111		#'
112		#' @param s1 A vector of numerics drawn from a gaussian distribution.
113		#' @examples
114		#' .conj_lognormal_sv(
115		#' s1 = rlnorm(100, log(130), log(1.3)),
116		#' priors = list(mu = 5, sd = 5),
117		#' plot = FALSE,
118		#' cred.int.level = 0.89
119		#' )
120		#' @keywords internal
121		#' @noRd
122
123		.conj_lognormal_sv <- function(s1 = NULL, priors = NULL,
124		plot = FALSE, support = NULL, cred.int.level = NULL,
125		calculatingSupport = FALSE) {
126	14x	out <- list()
127		#* `make default prior if none provided`
128	14x	if (is.null(priors)) {
129	4x	priors <- list(mu = 0, sd = 5)
130		}
131		#* `Get mean of s1`
132	14x	x_bar <- mean(s1)
133	14x	mu_s1 <- log(x_bar / (sqrt(var(s1) / x_bar^2) + 1))
134		#* `Get sigma of s1`
135	14x	sigma_s1 <- sqrt(log((var(s1)) / (x_bar^2) + 1))
136		#* `Update Normal Distribution of Mu`
137		#* sufficient stats: n, mean of log data \| precision
138	14x	n <- length(s1)
139	14x	m <- priors$mu[1]
140	14x	p <- 1 / (priors$sd[1]^2) # precision
141	14x	mu_prime <- ((m * p) + (n * p * mu_s1)) / (p + (n * p))
142	14x	precision_prime <- (p + (n * p))
143	14x	var_prime <- 1 / precision_prime
144	14x	sd_prime <- sqrt(var_prime)
145		#* `Define support if it is missing`
146	14x	if (is.null(support) && calculatingSupport) {
147	7x	quantiles <- stats::qnorm(c(0.0001, 0.9999), mu_prime, sd_prime)
148	7x	return(quantiles)
149		}
150		#* `posterior`
151	7x	dens1 <- dnorm(support, mu_prime, sd_prime)
152	7x	pdf1 <- dens1 / sum(dens1)
153	7x	hde1 <- mu_prime
154	7x	hdi1 <- qnorm(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), mu_prime, sd_prime)
155		#* `Store summary`
156	7x	out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
157	7x	out$posterior$mu <- mu_prime
158	7x	out$posterior$sd <- sd_prime
159	7x	out$posterior$lognormal_sigma <- sigma_s1 # returning this as a number, not a distribution
160		#* `Make Posterior Draws`
161	7x	out$posteriorDraws <- rnorm(10000, mu_prime, sd_prime)
162	7x	out$pdf <- pdf1
163		#* `save s1 data for plotting`
164	7x	if (plot) {
165	2x	out$plot_df <- data.frame(
166	2x	"range" = support,
167	2x	"prob" = pdf1,
168	2x	"sample" = rep("Sample 1", length(support))
169		)
170		}
171	7x	return(out)
172		}

1		#' @description
2		#' Internal function for calculating the pareto distribution of the upper boundary of a uniform
3		#' distribution represented by single value traits.
4		#' @param s1 A vector of numerics drawn from a uniform distribution.
5		#' @examples
6		#' out <- .conj_bivariate_lognormal_sv(
7		#' s1 = rlnorm(10, log(20), 1), cred.int.level = 0.95,
8		#' plot = FALSE
9		#' )
10		#' lapply(out, head)
11		#'
12		#' @keywords internal
13		#' @noRd
14
15		.conj_bivariate_lognormal_sv <- function(s1 = NULL, priors = NULL,
16		plot = FALSE, support = NULL, cred.int.level = NULL,
17		calculatingSupport = FALSE) {
18	4x	out <- list()
19		#* `make default prior if none provided`
20		#* conjugate prior needs alpha, beta, mu, prec (or var or sd)
21		#* precision is Gamma(alpha, beta)
22		#* mu is T_[2*alpha](mu, precision)
23	4x	if (is.null(priors)) {
24	4x	priors <- list(mu = 0, sd = 10, a = 1, b = 1)
25		}
26		#* `Extract prior components`
27	4x	alpha <- priors$a[1]
28	4x	beta <- priors$b[1]
29	4x	mu <- priors$mu[1]
30	4x	prec <- 1 / (priors$sd^2)
31		#* `Calculate sufficient statistics`
32	4x	n <- length(s1)
33	4x	x_bar <- mean(log(s1))
34	4x	ss <- sum((s1 - x_bar)^2)
35		#* `Update priors with sufficient statistics`
36	4x	alpha_prime <- alpha + (n / 2)
37	4x	beta_prime <- 1 / ((1 / beta) + (ss / 2) + ((prec * n * ((x_bar - mu)^2)) / (2 * (prec + n))))
38	4x	mu_prime <- ((prec * mu) + (n * x_bar)) / (prec + n)
39	4x	prec_prime <- prec + n
40	4x	df_prime <- 2 * alpha_prime
41	4x	prec_prime_t <- alpha_prime * prec_prime * beta_prime
42	4x	sigma_prime <- sqrt(1 / prec_prime_t)
43		#* `Define bivariate support if it is missing`
44	4x	if (is.null(support)) {
45	2x	quantiles_mu <- extraDistr::qlst(c(0.0001, 0.9999), df_prime, mu_prime, sigma_prime)
46	2x	quantiles_prec <- stats::qgamma(c(0.0001, 0.9999), shape = alpha_prime, scale = beta_prime)
47	2x	support_mu <- seq(quantiles_mu[1], quantiles_mu[2], length.out = 10000)
48	2x	support_prec <- seq(quantiles_prec[1], quantiles_prec[2], length.out = 10000)
49	2x	if (calculatingSupport) {
50	2x	return(list("Mu" = quantiles_mu, "Prec" = quantiles_prec))
51		}
52		} else {
53	2x	support_mu <- support$Mu
54	2x	support_prec <- support$Prec
55		}
56		#* `Make Posterior Draws`
57	2x	out$posteriorDraws <- .conj_biv_rough_sampling(
58	2x	10000, alpha_prime, beta_prime,
59	2x	mu_prime, sigma_prime, df_prime
60		)
61		#* `posterior`
62	2x	dens_mu <- extraDistr::dlst(support_mu, df_prime, mu_prime, sigma_prime)
63	2x	dens_prec <- stats::dgamma(support_prec, shape = alpha_prime, scale = beta_prime)
64
65	2x	pdf_mu <- dens_mu / sum(dens_mu)
66	2x	pdf_prec <- dens_prec / sum(dens_prec)
67	2x	out$pdf <- list("Mu" = pdf_mu, "Prec" = pdf_prec)
68
69	2x	hde_mu <- mu_prime
70	2x	hde_prec <- .gammaHDE(shape = alpha_prime, scale = beta_prime)
71	2x	hdi_mu <- -1 * rev(extraDistr::qlst(
72	2x	c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
73	2x	df_prime, mu_prime, sigma_prime
74		))
75	2x	hdi_prec <- -1 * rev(stats::qgamma(
76	2x	c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
77	2x	shape = alpha_prime, scale = beta_prime
78		))
79
80		#* `Store summary`
81	2x	out$summary <- data.frame(
82	2x	HDE_1 = c(hde_mu, hde_prec),
83	2x	HDI_1_low = c(hdi_mu[1], hdi_prec[1]),
84	2x	HDI_1_high = c(hdi_mu[2], hdi_prec[2]),
85	2x	param = c("Mu", "Prec")
86		)
87	2x	out$posterior <- list(
88	2x	"mu" = mu_prime, "sd" = sigma_prime,
89	2x	"a" = alpha_prime, "b" = beta_prime
90		)
91		#* `save s1 data for plotting`
92	2x	if (plot) {
93	2x	out$plot_df <- data.frame(
94	2x	"range" = c(support_mu, support_prec),
95	2x	"prob" = c(pdf_mu, pdf_prec),
96	2x	"param" = rep(c("Mu", "Prec"), each = length(support_mu)),
97	2x	"sample" = rep("Sample 1", 2 * length(support_mu))
98		)
99		}
100	2x	return(out)
101		}

1		#' Helper function for visualizing differences in GAMs fit with \code{mgcv::gam}
2		#'
3		#' Note that using GAMs will be less useful than fitting parameterized models as supported by
4		#' \code{growthSS} and \code{fitGrowth} for common applications in plant phenotyping.
5		#'
6		#' @param model A model fit with smooth terms by \code{mgcv::gam}
7		#' @param newdata A data.frame of new data to use to make predictions. If this is left NULL
8		#' (the default) then
9		#' an attempt is made to make newdata using the first smooth term in the formula.
10		#' See examples for guidance on making appropriate newdata
11		#' @param g1 A character string for the level of byVar to use as the first group to compare,
12		#' if plot=TRUE then this will be shown in blue.
13		#' @param g2 The second group to compare (comparison will be g1 - g2). If plot=TRUE then this will be
14		#' shown in red.
15		#' @param byVar Categorical variable name used to separate splines as a string.
16		#' @param smoothVar The variable that splines were used on. This will often be a time variable.
17		#' @param cis Confidence interval levels, can be multiple. For example, 0.95 would return Q_0.025 and
18		#' Q_0.975 columns, and c(0.9, 0.95) would return Q_0.025, Q_0.05, Q_0.95, and Q_0.975 columns.
19		#' Defaults to \code{seq(0.05, 0.95, 0.05)}
20		#' @param unconditional Logical, should unconditional variance-covariance be used in calculating
21		#' standard errors. Defaults to TRUE.
22		#' @param plot Logical, should a plot of the difference be returned? Defaults to TRUE.
23		#'
24		#' @keywords gam
25		#' @importFrom mgcv gam s
26		#' @importFrom stats vcov predict df.residual qt
27		#' @importFrom viridis viridis
28		#' @import ggplot2
29		#' @import patchwork
30		#' @return A dataframe or a list containing a ggplot and a dataframe
31		#' @examples
32		#'
33		#' ex <- pcvr::growthSim("logistic",
34		#' n = 20, t = 25,
35		#' params = list(
36		#' "A" = c(200, 160),
37		#' "B" = c(13, 11),
38		#' "C" = c(3, 3.5)
39		#' )
40		#' )
41		#'
42		#' m <- mgcv::gam(y ~ group + s(time, by = factor(group)), data = ex)
43		#'
44		#' support <- expand.grid(
45		#' time = seq(min(ex$time), max(ex$time), length = 400),
46		#' group = factor(unique(ex$group))
47		#' )
48		#'
49		#' out <- gam_diff(
50		#' model = m, newdata = support, g1 = "a", g2 = "b",
51		#' byVar = "group", smoothVar = "time", plot = TRUE
52		#' )
53		#' dim(out$data)
54		#' out$plot
55		#' out2 <- gam_diff(
56		#' model = m, g1 = "a", g2 = "b", byVar = NULL, smoothVar = NULL, plot = TRUE
57		#' )
58		#' @export
59
60		gam_diff <- function(model, newdata = NULL, g1, g2, byVar = NULL, smoothVar = NULL,
61		cis = seq(0.05, 0.95, 0.05), unconditional = TRUE, plot = TRUE) {
62	2x	form <- model$formula
63	2x	rhs <- as.character(form)[3]
64	2x	rg <- regexpr("s\\([a-zA-Z0-9.]+", rhs)
65	2x	xTerm <- sub("s\\(", "", regmatches(rhs, rg)[1])
66	2x	rg2 <- regexpr("by\\s?=\\s?.*[a-zA-Z0-9.]+", rhs)
67	2x	byTerm <- sub(".*\\(", "", sub("by\\s?=\\s?", "", regmatches(rhs, rg2)[1]))
68	2x	mdf <- model$model
69
70	2x	if (is.null(newdata)) {
71	1x	newdata <- expand.grid(
72	1x	x = seq(min(mdf[[xTerm]]), max(mdf[[xTerm]]),
73	1x	length.out = round(diff(range(mdf[[xTerm]])) * 500)
74		),
75	1x	g = factor(unique(mdf[[byTerm]]))
76		)
77	1x	colnames(newdata) <- c(xTerm, byTerm)
78		}
79	2x	if (is.null(byVar)) {
80	1x	byVar <- byTerm
81		}
82	2x	if (is.null(smoothVar)) {
83	1x	smoothVar <- xTerm
84		}
85
86	2x	xp <- stats::predict(model, newdata = newdata, type = "lpmatrix")
87	2x	c1 <- grepl(g1, colnames(xp))
88	2x	c2 <- grepl(g2, colnames(xp))
89	2x	r1 <- newdata[[byVar]] == g1
90	2x	r2 <- newdata[[byVar]] == g2
91		## difference rows of xp for data from comparison
92	2x	X <- xp[r1, ] - xp[r2, ]
93		## zero out cols of X related to splines for other lochs
94	2x	X[, !(c1 \| c2)] <- 0
95		## zero out the parametric cols
96	2x	X[, !grepl("^s\\(", colnames(xp))] <- 0
97	2x	dif <- X %*% coef(model)
98	2x	se <- sqrt(rowSums((X %% stats::vcov(model, unconditional = unconditional)) X))
99	2x	df.resid <- stats::df.residual(model)
100
101	2x	cis_diff_df <- do.call(cbind, lapply(cis, function(ci) {
102	38x	crit <- stats::qt(1 - ((1 - ci) / 2), df.resid, lower.tail = TRUE)
103	38x	upr <- dif + (crit * se)
104	38x	lwr <- dif - (crit * se)
105	38x	setNames(data.frame(upr, lwr), paste0(
106	38x	c("Q_diff_", "Q_diff_"),
107	38x	round(c(1 - ((1 - ci) / 2), 1 - (1 - ((1 - ci) / 2))), 3)
108		))
109		}))
110	2x	cis_diff_df <- cis_diff_df[, order(colnames(cis_diff_df))]
111
112	2x	out_df <- cbind(data.frame(g1 = g1, g2 = g2, mu = dif, se = se), cis_diff_df)
113	2x	if (plot) {
114		#* `g1 model CIs`
115	2x	x_g1 <- xp[r1, ]
116		## keep only relevant splines and intercept term
117	2x	c1_g1 <- grepl(g1, colnames(xp)) \| grepl("\\(Intercept\\)", colnames(xp))
118	2x	x_g1[, !(c1_g1)] <- 0
119		## zero out the parametric cols
120	2x	x_g1[, !grepl("\\(Intercept\\)\|^s\\(", colnames(xp))] <- 0
121	2x	g1_vals <- x_g1 %*% coef(model)
122	2x	se_g1 <- sqrt(rowSums((x_g1 %% stats::vcov(model, unconditional = unconditional)) x_g1))
123	2x	cis_g1_df <- do.call(cbind, lapply(cis, function(ci) {
124	38x	crit <- stats::qt(1 - ((1 - ci) / 2), df.resid, lower.tail = TRUE)
125	38x	upr <- g1_vals + (crit * se_g1)
126	38x	lwr <- g1_vals - (crit * se_g1)
127	38x	setNames(data.frame(upr, lwr), paste0(
128	38x	c("Q_g1_", "Q_g1_"),
129	38x	round(c(1 - ((1 - ci) / 2), 1 - (1 - ((1 - ci) / 2))), 3)
130		))
131		}))
132	2x	cis_g1_df <- cis_g1_df[, order(colnames(cis_g1_df))]
133		#* `g2 model CIs`
134	2x	x_g2 <- xp[r2, ]
135		## keep only relevant splines and intercept term
136	2x	c2_g2 <- grepl(g2, colnames(xp)) \| grepl("\\(Intercept\\)", colnames(xp))
137	2x	x_g2[, !(c2_g2)] <- 0
138		## zero out the parametric cols
139	2x	x_g2[, !grepl("\\(Intercept\\)\|^s\\(", colnames(xp))] <- 0
140	2x	g2_vals <- x_g2 %*% coef(model)
141	2x	se_g2 <- sqrt(rowSums((x_g2 %% stats::vcov(model, unconditional = unconditional)) x_g2))
142	2x	cis_g2_df <- do.call(cbind, lapply(cis, function(ci) {
143	38x	crit <- stats::qt(1 - ((1 - ci) / 2), df.resid, lower.tail = TRUE)
144	38x	upr <- g2_vals + (crit * se_g2)
145	38x	lwr <- g2_vals - (crit * se_g2)
146	38x	setNames(data.frame(upr, lwr), paste0(
147	38x	c("Q_g2_", "Q_g2_"),
148	38x	round(c(1 - ((1 - ci) / 2), 1 - (1 - ((1 - ci) / 2))), 3)
149		))
150		}))
151	2x	cis_g2_df <- cis_g2_df[, order(colnames(cis_g2_df))]
152
153	2x	out_df <- cbind(out_df, cis_g1_df, cis_g2_df)
154		}
155
156	2x	out_df$df.resid <- df.resid
157
158	2x	smoothVarRange <- range(newdata[[smoothVar]], na.rm = TRUE)
159	2x	smoothVarOut <- seq(min(smoothVarRange), max(smoothVarRange), length.out = length(dif))
160	2x	out_df[[smoothVar]] <- smoothVarOut
161	2x	out <- out_df
162	2x	if (plot) {
163	2x	p_diff <- .plot_gam_diff(out_df, name_pattern = "Q_diff_") +
164	2x	ggplot2::theme(
165	2x	axis.title.x.bottom = ggplot2::element_blank(),
166	2x	axis.text.x.bottom = ggplot2::element_blank()
167		)
168	2x	p_model <- .plot_gam_diff(out_df,
169	2x	name_pattern = "Q_g1_",
170	2x	name_pattern2 = "Q_g2_"
171		)
172	2x	layout_obj <- patchwork::plot_layout(
173	2x	design = c(
174	2x	patchwork::area(1, 1, 4, 6),
175	2x	patchwork::area(5, 1, 6, 6)
176		)
177		)
178	2x	patchPlot <- p_model / p_diff + layout_obj
179	2x	out <- list("data" = out_df, "plot" = patchPlot)
180		}
181	2x	return(out)
182		}
183
184		#' ***********************************************************************************************
185		#' ************* `Plot difference in smooths` **************************************
186		#' ***********************************************************************************************
187		#' @description
188		#' Internal function for plotting spline_diff output
189		#'
190		#' @keywords internal
191		#' @noRd
192
193		.plot_gam_diff <- function(df, name_pattern = "Q_diff_", name_pattern2 = NULL) {
194	4x	x <- colnames(df)[ncol(df)]
195	4x	nms <- colnames(df)
196	4x	nms <- as.numeric(sub(name_pattern, "", nms[grepl(paste0("^", name_pattern), nms)]))
197	4x	cis <- numeric()
198	4x	i <- 1
199	4x	while (length(nms) > 1) {
200	76x	cis[i] <- max(nms) - min(nms)
201	76x	nms <- nms[-which.max(nms)]
202	76x	nms <- nms[-which.min(nms)]
203	76x	i <- i + 1
204		}
205	4x	cis <- rev(cis)
206	4x	virPal <- viridis::viridis(n = length(cis), option = "mako", direction = -1, begin = 0.1)
207
208	4x	if (is.null(name_pattern2)) {
209	2x	lineLayer <- list(
210	2x	ggplot2::geom_line(ggplot2::aes(y = .data[["mu"]])),
211	2x	ggplot2::geom_hline(yintercept = 0, linetype = 5),
212	2x	ggplot2::labs(y = paste0(df[1, "g1"], " - ", df[1, "g2"]))
213		)
214		} else {
215	2x	lineLayer <- ggplot2::labs(y = "Model Prediction")
216		}
217
218	4x	splinePlot <- ggplot2::ggplot(df, aes(x = .data[[x]])) +
219	4x	lapply(rev(seq_along(cis)), function(i) {
220	76x	ci <- cis[i]
221	76x	ggplot2::geom_ribbon(
222	76x	ggplot2::aes(
223	76x	ymin = .data[[paste0(name_pattern, 1 - (1 - ((1 - ci) / 2)))]],
224	76x	ymax = .data[[paste0(name_pattern, 1 - ((1 - ci) / 2))]]
225		),
226	76x	fill = virPal[i], alpha = 0.5
227		)
228		}) +
229	4x	lineLayer +
230	4x	pcv_theme()
231
232	4x	if (!is.null(name_pattern2)) {
233	2x	virPal2 <- viridis::viridis(n = length(cis), option = "inferno", direction = -1, begin = 0.1)
234	2x	splinePlot <- splinePlot +
235	2x	lapply(rev(seq_along(cis)), function(i) {
236	38x	ci <- cis[i]
237	38x	ggplot2::geom_ribbon(
238	38x	ggplot2::aes(
239	38x	ymin = .data[[paste0(name_pattern2, 1 - (1 - ((1 - ci) / 2)))]],
240	38x	ymax = .data[[paste0(name_pattern2, 1 - ((1 - ci) / 2))]]
241		),
242	38x	fill = virPal2[i], alpha = 0.5
243		)
244		})
245		}
246
247	4x	return(splinePlot)
248		}

1		#' Function to visualize brms models similar to those made using growthSS outputs.
2		#'
3		#' Models fit using \link{growthSS} inputs by \link{fitGrowth} (and similar models made through other
4		#' means) can be visualized easily using this function. This will generally be called by
5		#' \code{growthPlot}.
6		#'
7		#' @param fit A brmsfit object, similar to those fit with \code{\link{growthSS}} outputs.
8		#' @param form A formula similar to that in \code{growthSS} inputs specifying the outcome,
9		#' predictor, and grouping structure of the data as \code{outcome ~ predictor\|individual/group}.
10		#' @param df An optional dataframe to use in plotting observed growth curves on top of the model.
11		#' @param groups An optional set of groups to keep in the plot.
12		#' Defaults to NULL in which case all groups in the model are plotted.
13		#' @param timeRange An optional range of times to use. This can be used to view predictions for
14		#' future data if the available data has not reached some point (such as asymptotic size),
15		#' although prediction using splines outside of the observed range is not necessarily reliable.
16		#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
17		#' @param hierarchy_value If a hierarchical model is being plotted, what value should the
18		#' hiearchical predictor be? If left NULL (the default) the mean value is used.
19		#' @param vir_option Viridis color scale to use for plotting credible intervals. Defaults to "plasma".
20		#' @keywords growth-curve brms
21		#' @import ggplot2
22		#' @import viridis
23		#' @importFrom stats as.formula
24		#' @examples
25		#' \donttest{
26		#' simdf <- growthSim(
27		#' "logistic",
28		#' n = 20, t = 25,
29		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
30		#' )
31		#' ss <- growthSS(
32		#' model = "logistic", form = y ~ time \| id / group, sigma = "spline",
33		#' list("A" = 130, "B" = 10, "C" = 3),
34		#' df = simdf, type = "brms"
35		#' )
36		#' fit <- fitGrowth(ss, backend = "cmdstanr", iter = 500, chains = 1, cores = 1)
37		#' growthPlot(fit = fit, form = y ~ time \| group, groups = "a", df = ss$df)
38		#' }
39		#'
40		#' @return Returns a ggplot showing a brms model's credible
41		#' intervals and optionally the individual growth lines.
42		#'
43		#' @export
44
45		brmPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE,
46		hierarchy_value = NULL, vir_option = "plasma") {
47	!	fitData <- fit$data
48	!	parsed_form <- .parsePcvrForm(form, df)
49	!	if (!is.numeric(fitData[, parsed_form$x]) && !parsed_form$USEG && !parsed_form$USEID) {
50	!	p <- .brmStaticPlot(fit, form, df, groups, facetGroups, vir_option, fitData, parsed_form)
51	!	return(p)
52		}
53	!	p <- .brmLongitudinalPlot(
54	!	fit, form, df, groups, timeRange, facetGroups,
55	!	hierarchy_value, vir_option, fitData, parsed_form
56		)
57	!	return(p)
58		}
59
60		#' @keywords internal
61		#' @noRd
62		.brmStaticPlot <- function(fit, form, df = NULL, groups = NULL, facetGroups = TRUE,
63		vir_option = "plasma", fitData, parsed_form) {
64	!	y <- parsed_form$y
65	!	x <- parsed_form$x
66	!	individual <- parsed_form$individual
67	!	if (individual == "dummyIndividual") {
68	!	individual <- NULL
69		}
70	!	group <- parsed_form$group
71	!	df <- parsed_form$data
72	!	probs <- seq(from = 99, to = 1, by = -2) / 100
73	!	newData <- data.frame(
74	!	x = unique(fitData[[x]])
75		)
76	!	colnames(newData) <- x
77	!	predictions <- cbind(newData, predict(fit, newData, probs = probs))
78	!	if (!is.null(groups)) {
79	!	predictions <- predictions[predictions$group %in% groups, ]
80	!	if (!is.null(df)) {
81	!	df <- df[df[[group]] %in% groups, ]
82		}
83		}
84		#* `facetGroups`
85	!	facetLayer <- NULL
86	!	if (facetGroups && length(unique(fitData[[group]])) > 1) {
87	!	facetLayer <- ggplot2::facet_wrap(as.formula(paste0("~", group)))
88		}
89		#* `lengthen predictions`
90	!	max_prime <- 0.99
91	!	min_prime <- 0.01
92	!	max_obs <- 49
93	!	min_obs <- 1
94	!	c1 <- (max_prime - min_prime) / (max_obs - min_obs)
95	!	longPreds <- do.call(rbind, lapply(seq_len(nrow(predictions)), function(r) {
96	!	sub <- predictions[r, ]
97	!	do.call(rbind, lapply(seq(1, 49, 2), function(i) {
98	!	min <- paste0("Q", i)
99	!	max <- paste0("Q", 100 - i)
100	!	iter <- sub[, c(x, "Estimate")]
101	!	iter$q <- round(1 - (c1 * (i - max_obs) + max_prime), 2)
102	!	iter$min <- sub[[min]]
103	!	iter$max <- sub[[max]]
104	!	iter
105		}))
106		}))
107		#* `Make Numeric Groups`
108	!	longPreds$numericGroup <- as.numeric(as.factor(longPreds[[x]]))
109		#* `Make plot`
110	!	p <- ggplot2::ggplot(longPreds, ggplot2::aes(x = .data[[x]], y = .data$Estimate)) +
111	!	facetLayer +
112	!	ggplot2::labs(x = x, y = y) +
113	!	pcv_theme()
114	!	p <- p +
115	!	lapply(unique(longPreds$q), function(q) {
116	!	ggplot2::geom_rect(
117	!	data = longPreds[longPreds$q == q, ],
118	!	ggplot2::aes(
119	!	xmin = .data[["numericGroup"]] - c(0.45 * (1 - .data[["q"]])),
120	!	xmax = .data[["numericGroup"]] + c(0.45 * (1 - .data[["q"]])),
121	!	ymin = .data[["min"]],
122	!	ymax = .data[["max"]],
123	!	group = .data[[x]],
124	!	fill = .data[["q"]]
125	!	), alpha = 0.5
126		)
127		}) +
128	!	viridis::scale_fill_viridis(direction = -1, option = vir_option) +
129	!	ggplot2::labs(fill = "Credible\nInterval")
130	!	return(p)
131		}
132		#' @keywords internal
133		#' @noRd
134
135		.brmLongitudinalPlot <- function(fit, form, df = NULL, groups = NULL,
136		timeRange = NULL, facetGroups = TRUE,
137		hierarchy_value = NULL, vir_option = "plasma",
138		fitData, parsed_form) {
139	!	y <- parsed_form$y
140	!	x <- parsed_form$x
141	!	individual <- parsed_form$individual
142	!	hierarchical_predictor <- parsed_form$hierarchical_predictor
143	!	if (individual == "dummyIndividual") {
144	!	individual <- NULL
145		}
146	!	group <- parsed_form$group
147	!	df <- parsed_form$data
148	!	probs <- seq(from = 99, to = 1, by = -2) / 100
149	!	if (is.null(timeRange)) {
150	!	timeRange <- unique(fitData[[x]])
151		}
152	!	newData <- data.frame(
153	!	x = rep(timeRange, times = length(unique(fitData[[group]]))),
154	!	group = rep(unique(fitData[[group]]), each = length(timeRange)),
155	!	individual = rep(paste0("new_", seq_along(unique(fitData[[group]]))), each = length(timeRange))
156		)
157	!	colnames(newData) <- c(x, group, individual)
158	!	if (!is.null(hierarchical_predictor)) {
159	!	if (is.null(hierarchy_value)) {
160	!	hierarchy_value <- mean(fitData[[hierarchical_predictor]])
161		}
162	!	newData[[hierarchical_predictor]] <- hierarchy_value
163		}
164	!	predictions <- cbind(newData, predict(fit, newData, probs = probs))
165
166	!	if (!is.null(groups)) {
167	!	predictions <- predictions[predictions$group %in% groups, ]
168	!	if (!is.null(df)) {
169	!	df <- df[df[[group]] %in% groups, ]
170		}
171		}
172		#* `facetGroups`
173	!	facetLayer <- NULL
174	!	if (facetGroups && length(unique(fitData[[group]])) > 1) {
175	!	facetLayer <- ggplot2::facet_wrap(as.formula(paste0("~", group)))
176		}
177		#* `lengthen predictions`
178	!	max_prime <- 0.99
179	!	min_prime <- 0.01
180	!	max_obs <- 49
181	!	min_obs <- 1
182	!	c1 <- (max_prime - min_prime) / (max_obs - min_obs)
183	!	longPreds <- do.call(rbind, lapply(seq_len(nrow(predictions)), function(r) {
184	!	sub <- predictions[r, ]
185	!	do.call(rbind, lapply(seq(1, 49, 2), function(i) {
186	!	min <- paste0("Q", i)
187	!	max <- paste0("Q", 100 - i)
188	!	iter <- sub[, c(x, group, individual, "Estimate")]
189	!	iter$q <- round(1 - (c1 * (i - max_obs) + max_prime), 2)
190	!	iter$min <- sub[[min]]
191	!	iter$max <- sub[[max]]
192	!	iter
193		}))
194		}))
195		#* `Make plot`
196	!	p <- ggplot2::ggplot(longPreds, ggplot2::aes(x = .data[[x]], y = .data$Estimate)) +
197	!	facetLayer +
198	!	ggplot2::labs(x = x, y = y) +
199	!	pcv_theme()
200	!	p <- p +
201	!	lapply(unique(longPreds$q), function(q) {
202	!	ggplot2::geom_ribbon(
203	!	data = longPreds[longPreds$q == q, ],
204	!	ggplot2::aes(
205	!	ymin = .data[["min"]],
206	!	ymax = .data[["max"]],
207	!	group = .data[[group]],
208	!	fill = .data[["q"]]
209	!	), alpha = 0.5
210		)
211		}) +
212	!	viridis::scale_fill_viridis(direction = -1, option = vir_option) +
213	!	ggplot2::labs(fill = "Credible\nInterval")
214
215	!	if (!is.null(df) && !is.null(individual)) {
216	!	p <- p + ggplot2::geom_line(
217	!	data = df, ggplot2::aes(.data[[x]], .data[[y]],
218	!	group = interaction(.data[[individual]], .data[[group]])
219		),
220	!	color = "gray20", linewidth = 0.2
221		)
222		}
223	!	return(p)
224		}

1		#' Time conversion and plotting for bellwether data
2		#'
3		#' @param df Data frame to use, this can be in wide or long format.
4		#' @param mode One of "DAS", "DAP" or "DAE" (Days After Planting and Days After Emergence).
5		#' Defaults to adding all columns.
6		#' Note that if timeCol is not an integer then DAS is always returned.
7		#' @param plantingDelay If `mode` includes "DAP" then `plantingDelay` is used to adjust "DAS"
8		#' @param phenotype If `mode` includes "DAE" then this is the phenotype used to classify emergence.
9		#' @param cutoff If `mode` inlcludes "DAE" then this value is used to classify emergence.
10		#' Defaults to 1, meaning an image with a value of 1 or more for `phenotype` has "emerged".
11		#' @param timeCol Column of input time values, defaults to "timestamp".
12		#' If this is not an integer then it is assumed to be
13		#' a timestamp in the format of the format argument.
14		#' @param group Grouping variables to specify unique plants as a character vector.
15		#' This defaults to "Barcodes". These taken together should identify a unique plant across time,
16		#' although often "angle" or "rotation" should be added.
17		#' @param plot Logical, should plots of the new time variables be printed?
18		#' @param format An R POSIXct format, defaults to lemnatech standard format.
19		#' This is only used if timeCol is not an integer.
20		#' @param traitCol Column with phenotype names, defaults to "trait".
21		#' This should generally not need to be changed from the default.
22		#' If this and valueCol are present in colnames(df) then the data
23		#' is assumed to be in long format.
24		#' @param valueCol Column with phenotype values, defaults to "value".
25		#' This should generally not need to be changed from the default.
26		#' @param index Optionally a time to use as the beginning of the experiment. This
27		#' may be useful if you have multiple datasets or you are adding data from bw.water
28		#' and plants were watered before being imaged or if you want to index days off of
29		#' midnight. This defaults to NULL but will take any value coercible to POSIXct by
30		#' \code{as.POSIXct(... , tz="UTC")} such as "2020-01-01 18:30:00"
31		#' @keywords DAS time ggplot
32		#' @import ggplot2
33		#' @return The input dataframe with new integer columns for different ways
34		#' of describing time in the experiment. If plot is TRUE then a ggplot is also returned as part of
35		#' a list.
36		#' @export
37		#' @examples
38		#' \donttest{
39		#' sv <- read.pcv(
40		#' "https://raw.githubusercontent.com/joshqsumner/pcvrTestData/main/pcv4-single-value-traits.csv",
41		#' mode = "wide", reader = "fread"
42		#' )
43		#' sv$genotype = substr(sv$barcode, 3, 5)
44		#' sv$genotype = ifelse(sv$genotype == "002", "B73",
45		#' ifelse(sv$genotype == "003", "W605S",
46		#' ifelse(sv$genotype == "004", "MM", "Mo17")
47		#' )
48		#' )
49		#' sv$fertilizer = substr(sv$barcode, 8, 8)
50		#' sv$fertilizer = ifelse(sv$fertilizer == "A", "100",
51		#' ifelse(sv$fertilizer == "B", "50", "0")
52		#' )
53		#' sv <- bw.time(sv,
54		#' plantingDelay = 0, phenotype = "area_pixels", cutoff = 10,
55		#' timeCol = "timestamp", group = c("barcode", "rotation"), plot = FALSE
56		#' )
57		#'
58		#'
59		#' svl <- read.pcv(
60		#' "https://raw.githubusercontent.com/joshqsumner/pcvrTestData/main/pcv4-single-value-traits.csv",
61		#' mode = "long", reader = "fread"
62		#' )
63		#' svl$genotype = substr(svl$barcode, 3, 5)
64		#' svl$genotype = ifelse(svl$genotype == "002", "B73",
65		#' ifelse(svl$genotype == "003", "W605S",
66		#' ifelse(svl$genotype == "004", "MM", "Mo17")
67		#' )
68		#' )
69		#' svl$fertilizer = substr(svl$barcode, 8, 8)
70		#' svl$fertilizer = ifelse(svl$fertilizer == "A", "100",
71		#' ifelse(svl$fertilizer == "B", "50", "0")
72		#' )
73		#' svl <- bw.time(svl,
74		#' plantingDelay = 0, phenotype = "area_pixels", cutoff = 10, timeCol = "timestamp",
75		#' group = c("barcode", "rotation"), plot = FALSE
76		#' )
77		#' }
78		#'
79		bw.time <- function(df = NULL, mode = c("DAS", "DAP", "DAE"), plantingDelay = NULL,
80		phenotype = NULL, cutoff = 1, timeCol = "timestamp",
81		group = "Barcodes", plot = TRUE, format = "%Y-%m-%d %H:%M:%S",
82		traitCol = "trait", valueCol = "value", index = NULL) {
83	2x	wide <- .detectWideData(df, traitCol, valueCol) # see bwoutliers
84
85	2x	if (is.null(plantingDelay) && "DAP" %in% mode) {
86	1x	mode <- mode[-which(mode == "DAP")]
87		}
88	2x	if (is.null(phenotype) && "DAE" %in% mode) {
89	1x	mode <- mode[-which(mode == "DAE")]
90		}
91
92	2x	formatNonIntegerTimeRes <- .formatNonIntegerTime(df, timeCol, format, index)
93	2x	df <- formatNonIntegerTimeRes[["data"]]
94	2x	timeCol <- formatNonIntegerTimeRes[["timeCol"]]
95
96	2x	if ("DAP" %in% mode) {
97	1x	df$DAP <- df[[timeCol]] + plantingDelay
98		}
99	2x	if ("DAE" %in% mode) {
100	1x	df <- .daeHelper(df, group, wide, phenotype, cutoff, timeCol, traitCol, valueCol)
101		}
102
103	2x	rownames(df) <- NULL
104	2x	if (plot) {
105	1x	p <- .timePlottingHelper(df, phenotype, group, wide, mode, traitCol, valueCol)
106	1x	df <- list("data" = df, "plot" = p)
107		}
108	2x	return(df)
109		}
110
111		#' ***********************************************************************************************
112		#' ************* `fix non date times` **************************************
113		#' ***********************************************************************************************
114		#' @description
115		#' Internal function for time handling
116		#'
117		#' @keywords internal
118		#' @noRd
119
120		.formatNonIntegerTime <- function(df, timeCol, format, index) {
121	2x	if (!is.integer(df[[timeCol]])) {
122	2x	df[[timeCol]] <- as.POSIXct(strptime(df[[timeCol]], format = format))
123	2x	beg <- as.POSIXct(index, tz = "UTC")
124	2x	if (is.null(index)) {
125	2x	beg <- min(df[[timeCol]], na.rm = TRUE)
126		}
127	2x	df$DAS <- floor(as.numeric((df[[timeCol]] - beg) / 60 / 60 / 24))
128	2x	timeCol <- "DAS"
129		}
130	2x	return(list("data" = df, "timeCol" = timeCol))
131		}
132
133
134		#' ***********************************************************************************************
135		#' ************* `time plotting Helper` **************************************
136		#' ***********************************************************************************************
137		#' @description
138		#' Internal function for plotting time data
139		#'
140		#' @keywords internal
141		#' @noRd
142
143		.timePlottingHelper <- function(df, phenotype, group, wide, mode, traitCol, valueCol) {
144	1x	if (wide) {
145	1x	plotDat <- df
146	1x	plotDat$plotGroup <- interaction(plotDat[, c(group)])
147	1x	p <- lapply(mode, function(m) {
148	3x	ggplot2::ggplot(plotDat, ggplot2::aes(
149	3x	x = .data[[m]], y = .data[[phenotype]],
150	3x	group = .data$plotGroup
151		)) +
152	3x	ggplot2::geom_line() +
153	3x	ggplot2::labs(x = m, y = phenotype, title = m) +
154	3x	pcv_theme()
155		})
156	1x	return(p)
157	!	} else if (!wide) {
158	!	plotDat <- df[df[[traitCol]] == phenotype, ]
159	!	plotDat$plotGroup <- interaction(plotDat[, c(group)])
160	!	p <- lapply(mode, function(m) {
161	!	ggplot2::ggplot(plotDat, ggplot2::aes(
162	!	x = .data[[m]], y = .data[[valueCol]],
163	!	group = .data$plotGroup
164		)) +
165	!	ggplot2::geom_line() +
166	!	ggplot2::labs(x = m, y = phenotype, title = m) +
167	!	pcv_theme()
168		})
169	!	return(p)
170		}
171		}
172
173		#' ***********************************************************************************************
174		#' ************* `DAE Helper` **************************************
175		#' ***********************************************************************************************
176		#' @description
177		#' Internal function for dae calculation
178		#'
179		#' @keywords internal
180		#' @noRd
181
182		.daeHelper <- function(df, group, wide, phenotype, cutoff, timeCol, traitCol, valueCol) {
183	1x	if (wide) {
184	1x	dae_split <- interaction(df[, group])
185	1x	df <- do.call(rbind, lapply(split(df, dae_split), function(d) {
186	176x	subd <- d[d[[phenotype]] >= cutoff & !is.na(d[[phenotype]]), ]
187	176x	if (nrow(subd) == 0) {
188	1x	subd <- data.frame(DAS = max(df[[timeCol]]) + 1)
189	1x	colnames(subd) <- timeCol
190	1x	} # if all NA area then remove all rows
191	176x	d$DAE <- d[[timeCol]] - min(subd[[timeCol]], na.rm = TRUE)
192	176x	d
193		}))
194		} else {
195	!	dae_split <- interaction(df[, group])
196	!	df <- do.call(rbind, lapply(split(df, dae_split), function(d) {
197	!	subd <- d[d[[traitCol]] == phenotype & d[[valueCol]] >= cutoff & !is.na(d[[valueCol]]), ]
198	!	if (nrow(subd) == 0) {
199	!	subd <- data.frame(DAS = max(df[[timeCol]]) + 1)
200	!	colnames(subd) <- timeCol
201		}
202	!	d$DAE <- d[[timeCol]] - min(subd[[timeCol]], na.rm = TRUE)
203	!	d
204		}))
205		}
206	1x	return(df)
207		}

1		#' @description
2		#' Internal function for calculating posterior distribution of \Lambda parameter for poisson data.
3		#' The conjugate prior on Lambda is a Gamma(A,B)
4		#' A=B=0.5 is a reasonable weak default prior
5		#'
6		#' So if leaf count is Poisson distributed:
7		#' count ~ Pois(\labmda)
8		#' \labmda ~ gamma(A, B)
9		#' A = A_[prior] + sum(x)
10		#' B = B_[prior] / (1+n)
11		#'
12		#' via MoM \hat(\labmda) = = 1/n +sum^1_n(x)
13		#' @param s1 A vector of numerics drawn from a beta distribution.
14		#' @examples
15		#'
16		#' .conj_poisson_sv(
17		#' s1 = rpois(20, 10), priors = list(a = c(0.5, 0.5), b = c(0.5, 0.5)),
18		#' plot = FALSE
19		#' )
20		#'
21		#' @keywords internal
22		#' @noRd
23
24		.conj_poisson_sv <- function(s1 = NULL, priors = NULL,
25		plot = FALSE, support = NULL, cred.int.level = NULL,
26		calculatingSupport = FALSE) {
27		#* `Check samples`
28	13x	if (any(abs(s1 - round(s1)) > .Machine$double.eps^0.5) \|\| any(s1 < 0)) {
29	1x	stop("Only positive integers can be used in the Poisson distribution")
30		}
31		#* `make default prior if none provided`
32	12x	if (is.null(priors)) {
33	4x	priors <- list(a = 0.5, b = 0.5) # gamma prior on lambda
34		}
35
36	12x	out <- list()
37
38		#* `Use conjugate gamma prior on lambda`
39	12x	a1_prime <- priors$a[1] + sum(s1)
40	12x	b1_prime <- priors$b[1] + length(s1)
41		#* `Define support if it is missing`
42	12x	if (is.null(support) && calculatingSupport) {
43	6x	quantiles <- qgamma(c(0.0001, 0.9999), a1_prime, b1_prime)
44	6x	return(quantiles)
45		}
46		#* `calculate density over support``
47	6x	dens1 <- dgamma(support, a1_prime, b1_prime)
48	6x	pdf1 <- dens1 / sum(dens1)
49
50		#* `calculate highest density interval`
51	6x	hdi1 <- qgamma(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), a1_prime, b1_prime)
52
53		#* `calculate highest density estimate``
54	6x	hde1 <- .gammaHDE(shape = a1_prime, scale = 1 / b1_prime)
55
56		#* `save summary and parameters`
57	6x	out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
58	6x	out$posterior$a <- a1_prime
59	6x	out$posterior$b <- b1_prime
60		#* `Make Posterior Draws`
61	6x	out$posteriorDraws <- rgamma(10000, a1_prime, b1_prime)
62	6x	out$pdf <- pdf1
63		#* `keep data for plotting`
64	6x	if (plot) {
65	4x	out$plot_df <- data.frame(
66	4x	"range" = support, "prob" = pdf1,
67	4x	"sample" = rep("Sample 1", length(support))
68		)
69		}
70	6x	return(out)
71		}

1		#' Function to visualize models made by \link{fitGrowth}.
2		#'
3		#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
4		#' (and similar models made through other means) can be visualized easily using this function.
5		#'
6		#'
7		#' @param fit A model fit object (or a list of \code{nlrq} models) as returned by \code{fitGrowth}.
8		#' @param form A formula similar to that in \code{growthSS} inputs (or the \code{pcvrForm} part of the
9		#' output) specifying the outcome, predictor, and grouping structure of the data as
10		#' \code{outcome ~ predictor\|individual/group}. Generally this is given directly from
11		#' the growthSS output (\code{ss$pcvrForm}). If the formula does not include both individuals
12		#' and groups then lines from the data will not be plotted which may be best if your data does not
13		#' specify unique individuals and your model does not include autocorrelation.
14		#' @param groups An optional set of groups to keep in the plot.
15		#' Defaults to NULL in which case all groups in the model are plotted.
16		#' @param df A dataframe to use in plotting observed growth curves on top of the model and for making
17		#' predictions.
18		#' @param timeRange An optional range of times to use. This can be used to view predictions for
19		#' future data if the avaiable data has not reached some point (such as asymptotic size).
20		#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
21		#' @param groupFill logical, should groups have different colors? Defaults to the opposite of
22		#' facetGroups. If TRUE then
23		#' viridis colormaps are used in the order c('plasma', 'mako', 'viridis', 'inferno', 'cividis', 'magma',
24		#' 'turbo', 'rocket'). Alternatively this can be given as a vector of
25		#' viridis colormap names to use in a different order than above.
26		#' Note that for brms models this is ignored except if used to specify a different viridis color map
27		#' to use.
28		#' @param hierarchy_value If a hierarchical model is being plotted, what value should the
29		#' hiearchical predictor be? If left NULL (the default) the mean value is used.
30		#' @keywords growth-curve
31		#' @importFrom methods is
32		#' @examples
33		#'
34		#' simdf <- growthSim("logistic",
35		#' n = 20, t = 25,
36		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
37		#' )
38		#' ss <- growthSS(
39		#' model = "logistic", form = y ~ time \| id / group,
40		#' df = simdf, type = "nls"
41		#' )
42		#' fit <- fitGrowth(ss)
43		#' growthPlot(fit, form = ss$pcvrForm, df = ss$df)
44		#'
45		#' @return Returns a ggplot showing a brms model's credible
46		#' intervals and optionally the individual growth lines.
47		#'
48		#' @export
49
50		growthPlot <- function(fit, form, groups = NULL, df = NULL, timeRange = NULL,
51		facetGroups = TRUE, groupFill = !facetGroups, hierarchy_value = NULL) {
52	9x	if (is.logical(groupFill)) {
53	8x	virMaps <- c("plasma", "mako", "viridis", "inferno", "cividis", "magma", "turbo", "rocket")
54		} else {
55	1x	virMaps <- groupFill
56	1x	groupFill <- TRUE
57		}
58	9x	model_class <- class(fit)[1]
59	9x	if (methods::is(fit, "list")) {
60	2x	model_class <- class(fit[[1]])
61		}
62	9x	if (methods::is(fit, "brmsfit")) {
63	!	if (attr(fit$formula$formula, "nl")) { # non linear models are growth models
64	!	plot <- brmPlot(
65	!	fit = fit, form = form, groups = groups, df = df, timeRange = timeRange,
66	!	facetGroups = facetGroups, hierarchy_value = hierarchy_value, vir_option = virMaps[1]
67		)
68		} else { # linear models are survival models
69	!	plot <- brmSurvPlot(
70	!	fit = fit, form = form, groups = groups, df = df, timeRange = timeRange,
71	!	facetGroups = facetGroups
72		)
73		}
74		} else {
75	9x	plottingFunction <- match.fun(paste0(model_class, "Plot"))
76	9x	plot <- plottingFunction(
77	9x	fit = fit, form = form, groups = groups, df = df, timeRange = timeRange,
78	9x	facetGroups = facetGroups, groupFill = groupFill, virMaps
79		)
80		}
81	9x	return(plot)
82		}

1		#' Check priors used in ease of use brms functions
2		#'
3		#' @param priors A named list of means for prior distributions.
4		#' This takes the same input as the prior argument of \code{\link{growthSS}}.
5		#' Alternatively, if given the output of growthSS this will preform a prior predictive check
6		#' and return a plot from \code{\link{growthPlot}} of that check ignoring all other arguments.
7		#' Note that all priors must be
8		#' proper in that case (non-flat) and the fit is likely to be strange looking due to how thick
9		#' tailed the default priors from \code{\link{growthSS}} are.
10		#' @param type Either "density", the default, or a model as would be specified in \code{growthSS}
11		#' or \code{growthSim} such as "logistic", "gompertz", "monomolecular", "exponential",
12		#' "linear", "power law", "double logistic", or "double gompertz".
13		#' If this is a model type then n draws from the prior will be simulated as growth
14		#' trendlines and densities will be plotted on margins for some distributions.
15		#' @param n Numeric, if type is a model then how many draws from the prior should be simulated?
16		#' @param t Numeric, time passed to growthSim. Defaults to 25 (the growthSim default).
17		#' @keywords Bayesian brms priors
18		#' @return A named list of plots showing prior distributions that \code{growthSS} would use,
19		#' optionally with a plot of simulated growth curves using draws from those priors.
20		#' @import ggplot2
21		#' @import patchwork
22		#' @importFrom stats rlnorm dlnorm
23		#' @examples
24		#'
25		#' set.seed(123)
26		#' priors <- list("A" = c(100, 130), "B" = c(10, 8), "C" = c(0.2, 0.1))
27		#' plotPrior(priors)
28		#'
29		#' plotPrior(priors, "gompertz")[[1]]
30		#'
31		#' @export
32
33		plotPrior <- function(priors, type = "density", n = 200, t = 25) {
34	6x	if ("prior" %in% names(priors)) {
35	!	p <- .brms_prior_predictive(priors)
36	!	return(p)
37		}
38	6x	densPlots <- lapply(seq_along(priors), function(i) {
39	18x	pri <- priors[[i]]
40	18x	nm <- names(priors)[i]
41
42	18x	pri_df <- do.call(rbind, lapply(seq_along(pri), function(o) {
43	30x	prio <- pri[o]
44	30x	max <- ceiling(max(rlnorm(1000, log(max(pri)), 0.25)) * 1.1)
45	30x	support <- seq(0, max, length.out = 10000)
46	30x	dens <- dlnorm(support, meanlog = log(prio), sdlog = 0.25)
47	30x	pdf <- dens / sum(dens)
48	30x	data.frame(
49	30x	support = support,
50	30x	dens = pdf,
51	30x	param = nm,
52	30x	item = as.character(o)
53		)
54		}))
55
56	18x	ggplot2::ggplot(pri_df, ggplot2::aes(
57	18x	x = .data$support, y = .data$dens,
58	18x	fill = .data$item, group = .data$item
59		)) +
60	18x	ggplot2::geom_polygon(alpha = 0.5) +
61	18x	ggplot2::theme_minimal() +
62	18x	ggplot2::labs(y = "Density", title = nm, fill = "Prior")
63		})
64	6x	names(densPlots) <- names(priors)
65
66	6x	if (type == "density") {
67	3x	out <- densPlots
68		} else {
69	3x	simdf <- do.call(rbind, lapply(1:n, function(i) {
70	400x	iter_params <- .prior_sampler(priors)
71	400x	x <- growthSim(model = type, n = 1, t = t, params = iter_params)
72	400x	x$id <- paste0("id_", i)
73	400x	x
74		}))
75
76	3x	model_plot <- ggplot2::ggplot(
77	3x	simdf,
78	3x	ggplot2::aes(
79	3x	x = .data$time, y = .data$y, group = interaction(.data$id, .data$group),
80	3x	color = .data$group
81		)
82		) +
83	3x	ggplot2::geom_line(linewidth = 0.1) +
84	3x	ggplot2::theme_minimal() +
85	3x	ggplot2::guides(color = ggplot2::guide_legend(override.aes = list(linewidth = 5))) +
86	3x	ggplot2::labs(
87	3x	y = "Y", title = paste0(n, " curves simulated from prior draws"),
88	3x	color = "Prior"
89		) +
90	3x	ggplot2::theme(
91	3x	legend.position = "inside",
92	3x	legend.position.inside = c(0.9, 0.9)
93		)
94
95	3x	if (type %in% c("logistic", "gompertz", "weibull", "frechet", "gumbel")) {
96	3x	x <- "B"
97	3x	y <- "A"
98	3x	z <- "C"
99	!	} else if (type %in% c("monomolecular")) {
100	!	y <- "A"
101	!	x <- z <- NULL
102		} else {
103	!	x <- y <- z <- NULL
104		}
105	3x	out <- .plotPriorMarginPlots(model_plot, densPlots, x, y, z)
106		}
107
108	6x	return(out)
109		}
110
111		#' @description
112		#' Internal function for adding marginal plots to plotPrior
113		#' @keywords internal
114		#' @noRd
115
116		.plotPriorMarginPlots <- function(model_plot, densPlots, x, y, z) {
117	3x	xLims <- ggplot2::layer_scales(model_plot)$x$range$range
118	3x	yLims <- ggplot2::layer_scales(model_plot)$y$range$range
119	3x	model_plot_solo <- model_plot
120
121	3x	sum_non_null <- 0
122	3x	x_margin_plot <- NULL
123	3x	y_margin_plot <- NULL
124	3x	z_margin_plot <- NULL
125
126	3x	if (!is.null(y)) {
127	3x	y_margin_plot <- densPlots[[y]] +
128	3x	ggplot2::scale_y_reverse(position = "right") +
129	3x	ggplot2::scale_x_continuous(position = "top", limits = yLims) +
130	3x	ggplot2::labs(x = "Asymptote Prior") +
131	3x	ggplot2::coord_flip() +
132	3x	ggplot2::theme(
133	3x	plot.title = ggplot2::element_blank(), panel.grid = ggplot2::element_blank(),
134	3x	axis.text = ggplot2::element_blank(), axis.title.x = ggplot2::element_blank(),
135	3x	legend.position = "none"
136		)
137	3x	sum_non_null <- sum_non_null + 1
138		}
139
140	3x	if (!is.null(x)) {
141	3x	x_margin_plot <- densPlots[[x]] +
142	3x	ggplot2::labs(x = "Inflection Point Prior") +
143	3x	ggplot2::theme(
144	3x	plot.title = ggplot2::element_blank(), panel.grid = ggplot2::element_blank(),
145	3x	axis.text.y = ggplot2::element_blank(), axis.title.y = ggplot2::element_blank(),
146	3x	legend.position = "none"
147		) +
148	3x	ggplot2::coord_cartesian(xlim = xLims)
149	3x	sum_non_null <- sum_non_null + 1
150		}
151
152	3x	if (!is.null(z)) {
153	3x	z_margin_plot <- densPlots[[z]] +
154	3x	ggplot2::labs(x = "Growth Rate Prior") +
155	3x	ggplot2::theme(
156	3x	plot.title = ggplot2::element_blank(), panel.grid = ggplot2::element_blank(),
157	3x	axis.text.y = ggplot2::element_blank(), axis.title.y = ggplot2::element_blank(),
158	3x	legend.position = "none"
159		) +
160	3x	ggplot2::scale_x_continuous(n.breaks = 3)
161	3x	sum_non_null <- sum_non_null + 1
162		}
163
164	3x	if (sum_non_null == 3) {
165	3x	design <- c(
166	3x	patchwork::area(1, 1, 6, 6), # model plot
167	3x	patchwork::area(7, 1, 7, 6), # x margin
168	3x	patchwork::area(1, 7, 6, 7), # y margin
169	3x	patchwork::area(7, 7, 7, 7)
170	3x	) # "z" margin
171	3x	layout <- patchwork::plot_layout(design = design)
172	3x	model_plot <- model_plot + x_margin_plot + y_margin_plot + z_margin_plot + layout
173	!	} else if (!is.null(y_margin_plot) && is.null(x_margin_plot)) {
174	!	design <- c(
175	!	patchwork::area(1, 1, 6, 6), # model plot
176	!	patchwork::area(1, 7, 6, 7)
177	!	) # y margin
178	!	model_plot <- model_plot + y_margin_plot + patchwork::plot_layout(design = design)
179		}
180
181	3x	if (is(model_plot, "patchwork")) {
182	3x	densPlots[[length(densPlots) + 1]] <- model_plot_solo
183		}
184	3x	return(list("simulated" = model_plot, "distributions" = densPlots))
185		}
186
187
188
189
190		#' @description
191		#' Internal function for drawing from priors
192		#' @param priors priors as a list
193		#' @keywords internal
194		#' @noRd
195
196		.prior_sampler <- function(priors) {
197	400x	lapply(priors, function(pri) { # draw sample from prior
198	1200x	unlist(lapply(pri, function(mu) {
199	2400x	rlnorm(1, log(mu), 0.25)
200		}))
201		})
202		}
203
204		#' @description
205		#' Internal function for sampling a growthSS model's priors only
206		#' @param priors a list returned by growthSS
207		#' @keywords internal
208		#' @noRd
209
210		.brms_prior_predictive <- function(priors = NULL) {
211	!	dp <- brms::get_prior(priors$formula, priors$df, priors$family)
212	!	ssp <- priors$prior
213	!	dpi <- as.character(interaction(dp$coef, dp$dpar, dp$nlpar))
214	!	sspi <- as.character(interaction(ssp$coef, ssp$dpar, ssp$nlpar))
215	!	priors$prior <- rbind(ssp, dp[-which(dpi %in% sspi), ])
216	!	tryCatch(
217		{
218	!	m <- suppressMessages(
219	!	fitGrowth(priors,
220	!	iter = 1000,
221	!	chains = 1,
222	!	cores = 1,
223	!	sample_prior = "only",
224	!	silent = 2
225		)
226		)
227		},
228	!	error = function(err) {
229	!	message(paste0(
230	!	"Error trying to sample from priors distributions.",
231	!	"All priors must be proper (non-flat). Check prior specification in growthSS\n"
232		))
233	!	message("The original Error message is:")
234	!	stop(conditionMessage(err))
235		}
236		)
237	!	p <- growthPlot(m, form = priors$pcvrForm, df = priors$df)
238	!	return(p)
239		}

1		#' @description
2		#' Internal function for calculating \alpha and \beta of the gamma distributed variance of lognormal
3		#' data given an estimate of the lognormal \mu obtained via the method of moments using multi value
4		#' traits.
5		#' @param s1 A data.frame or matrix of multi value traits. The column names should include a number
6		#' representing the "bin".
7		#'
8		#' @examples
9		#' mv_ln <- mvSim(
10		#' dists = list(
11		#' rlnorm = list(meanlog = log(130), sdlog = log(1.2))
12		#' ),
13		#' n_samples = 30
14		#' )
15		#' .conj_lognormal2_mv(
16		#' s1 = mv_ln[, -1],
17		#' priors = NULL
18		#' plot = FALSE,
19		#' cred.int.level = 0.89,
20		#' )
21		#' @keywords internal
22		#' @noRd
23
24		.conj_lognormal2_mv <- function(s1 = NULL, priors = NULL,
25		plot = FALSE, support = NULL, cred.int.level = NULL,
26		calculatingSupport = FALSE) {
27	4x	out <- list()
28		#* `make default prior if none provided`
29	4x	if (is.null(priors)) {
30	4x	priors <- list(a = 1, b = 1) # prior on shape, scale of precision
31		}
32		#* `Reorder columns if they are not in the numeric order`
33	4x	histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
34	4x	bins_order <- sort(histColsBin, index.return = TRUE)$ix
35	4x	s1 <- s1[, bins_order]
36		#* `Loop over reps, get moments for each histogram`
37	4x	rep_distributions <- lapply(seq_len(nrow(s1)), function(i) {
38	120x	X1 <- rep(histColsBin[bins_order], as.numeric(s1[i, ]))
39		#* `Get mean of x1`
40	120x	x_bar <- mean(X1)
41	120x	mu_s1 <- log(x_bar / (sqrt(var(X1) / x_bar^2) + 1))
42		#* `Update Gamma Distribution of precision`
43		#* sufficient stats: n, ss
44	120x	ss <- nrow(s1) * mean((log(X1) - mu_s1)^2) # mean * nrow instead of sum for MV traits
45	120x	n1 <- nrow(s1)
46	120x	a_prime <- priors$a[1] + (n1 / 2)
47	120x	b_prime <- priors$b[1] + (ss / 2)
48	120x	return(list("a_prime" = a_prime, "b_prime" = b_prime, "ln_mu" = mu_s1))
49		})
50		#* `Unlist parameters`
51	4x	a_prime <- mean(unlist(lapply(rep_distributions, function(i) {
52	120x	i$a_prime
53		})))
54	4x	b_prime <- mean(unlist(lapply(rep_distributions, function(i) {
55	120x	i$b_prime
56		})))
57	4x	ln_mu_prime <- mean(unlist(lapply(rep_distributions, function(i) {
58	120x	i$ln_mu
59		})))
60		#* `Define support if it is missing`
61	4x	if (is.null(support) && calculatingSupport) {
62	2x	quantiles <- qgamma(c(0.0001, 0.9999), shape = a_prime, scale = b_prime)
63	2x	return(quantiles)
64		}
65		#* `posterior`
66	2x	dens1 <- dgamma(support, shape = a_prime, scale = b_prime)
67	2x	pdf1 <- dens1 / sum(dens1)
68	2x	hde1 <- .gammaHDE(shape = a_prime, scale = b_prime)
69	2x	hdi1 <- qgamma(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
70	2x	shape = a_prime, scale = b_prime
71		)
72		#* `Store summary`
73	2x	out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
74	2x	out$posterior$a <- a_prime
75	2x	out$posterior$b <- b_prime
76	2x	out$posterior$lognormal_mu <- ln_mu_prime # returning this as a number, not a distribution
77		#* `Make Posterior Draws`
78	2x	out$posteriorDraws <- rgamma(10000, shape = a_prime, scale = b_prime)
79	2x	out$pdf <- pdf1
80		#* `save s1 data for plotting`
81	2x	if (plot) {
82	2x	out$plot_df <- data.frame(
83	2x	"range" = support,
84	2x	"prob" = pdf1,
85	2x	"sample" = rep("Sample 1", length(support))
86		)
87		}
88	2x	return(out)
89		}
90
91
92
93		#' @description
94		#' Internal function for calculating \alpha and \beta of the gamma distributed precision of lognormal
95		#' data given an estimate of the lognormal \mu obtained via the method of moments using single value
96		#' traits.
97		#'
98		#' @param s1 A vector of numerics drawn from a gaussian distribution.
99		#' @examples
100		#' .conj_lognormal2_sv(
101		#' s1 = rlnorm(100, log(130), log(1.3)),
102		#' priors = NULL,
103		#' plot = FALSE,
104		#' cred.int.level = 0.89
105		#' )
106		#' @keywords internal
107		#' @noRd
108
109		.conj_lognormal2_sv <- function(s1 = NULL, priors = NULL,
110		plot = FALSE, support = NULL, cred.int.level = NULL,
111		calculatingSupport = FALSE) {
112	4x	out <- list()
113		#* `make default prior if none provided`
114	4x	if (is.null(priors)) {
115	4x	priors <- list(a = 1, b = 1) # prior on shape, scale of precision
116		}
117		#* `Get mean of s1`
118	4x	x_bar <- mean(s1)
119	4x	mu_s1 <- log(x_bar / (sqrt(var(s1) / x_bar^2) + 1))
120		#* `Update Gamma Distribution of precision`
121		#* sufficient stats: n, ss
122	4x	ss <- sum((log(s1) - mu_s1)^2)
123	4x	n1 <- length(s1)
124	4x	a_prime <- priors$a[1] + (n1 / 2)
125	4x	b_prime <- priors$b[1] + (ss / 2)
126		#* `Define support if it is missing`
127	4x	if (is.null(support) && calculatingSupport) {
128	2x	quantiles <- qgamma(c(0.0001, 0.9999), shape = a_prime, scale = b_prime)
129	2x	return(quantiles)
130		}
131		#* `posterior`
132	2x	dens1 <- dgamma(support, shape = a_prime, scale = b_prime)
133	2x	pdf1 <- dens1 / sum(dens1)
134	2x	hde1 <- .gammaHDE(shape = a_prime, scale = b_prime)
135	2x	hdi1 <- qgamma(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
136	2x	shape = a_prime, scale = b_prime
137		)
138		#* `Store summary`
139	2x	out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
140	2x	out$posterior$a <- a_prime
141	2x	out$posterior$b <- b_prime
142	2x	out$posterior$lognormal_mu <- mu_s1 # returning this as a number, not a distribution
143		#* `Make Posterior Draws`
144	2x	out$posteriorDraws <- rgamma(10000, shape = a_prime, scale = b_prime)
145	2x	out$pdf <- pdf1
146		#* `save s1 data for plotting`
147	2x	if (plot) {
148	2x	out$plot_df <- data.frame(
149	2x	"range" = support,
150	2x	"prob" = pdf1,
151	2x	"sample" = rep("Sample 1", length(support))
152		)
153		}
154	2x	return(out)
155		}

1		#' Hypothesis testing for \link{fitGrowth} models.
2		#'
3		#' @param ss A list output from \link{growthSS}. This is not required for nls, nlme, and brms models
4		#' if \code{test} is given in \code{brms::hypothesis} style as a written statement.
5		#' @param fit A model (or list of nlrq models) output from \link{fitGrowth}.
6		#' @param test A description of the hypothesis to test. This can take two main forms,
7		#' either the parameter names to vary before comparing a nested model ("A", "B", "C") using an anova
8		#' or a hypothesis test/list of hypothesis tests written as character strings.
9		#' The latter method is not implemented for \code{nlrq} models. If this is a vector of parameters
10		#' to test in the model then they should be parameters which vary by group in your original model
11		#' and that you want to test against a null model where they do not vary by group.
12		#' Alternatively for nlrq models this can be a comparison of model terms
13		#' written as \code{"group_X\|tau\|par - group_Y\|tau\|par"}, which uses a fat tailed T distribution to make
14		#' comparisons on the means of each quantile estimate. For GAMs these tests compare the model with
15		#' splines either by group or interacting with group to a model that ignores the grouping in the data.
16		#' If this is a list of hypothesis tests then they should describe tests similar to
17		#' "A.group1 - A.group2*1.1" and can be thought of as contrasts. For brms models the "test" argument
18		#' is passed to brms::hypothesis, which has extensive documentation and is very flexible.
19		#' Note that for survreg the \code{survival::survdiff} function is used so fewer hypothesis testing
20		#' options are available and flexsurv models are tested using contrasts via \code{flexsurv::standsurv}.
21		#' @keywords hypothesis brms nlme nls nlrq mgcv
22		#' @importFrom stats getCall logLik pchisq anova as.formula setNames vcov coef pt
23		#' @importFrom nlme pdIdent corAR1 fixef
24		#' @importFrom extraDistr qlst dlst
25		#' @importFrom methods is
26		#' @importFrom car deltaMethod
27		#' @importFrom survival survdiff
28		#'
29		#' @details
30		#' For nls and nlme models an anova is run and returned as part of a list along with the null model.
31		#' For nlrq models several assumptions are made and a likelihood ratio test for each tau
32		#' is run and returned as a list.
33		#'
34		#'
35		#' @return A list containing an anova object comparing non-linear growth models and the null model.
36		#'
37		#' @examples
38		#'
39		#' set.seed(123)
40		#' simdf <- growthSim("logistic",
41		#' n = 20, t = 25,
42		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
43		#' )
44		#' ss <- suppressMessages(growthSS(
45		#' model = "logistic", form = y ~ time \| id / group,
46		#' df = simdf, type = "nlrq"
47		#' ))
48		#' fit <- fitGrowth(ss)
49		#' testGrowth(ss, fit, "A")
50		#' testGrowth(ss, fit, "a\|0.5\|A > b\|0.5\|A")
51		#'
52		#' ss2 <- suppressMessages(growthSS(
53		#' model = "logistic", form = y ~ time \| id / group,
54		#' df = simdf, type = "nls"
55		#' ))
56		#' fit2 <- fitGrowth(ss2)
57		#' testGrowth(ss2, fit2, "A")$anova
58		#' coef(fit2) # check options for contrast testing
59		#' testGrowth(ss2, fit2, "A1 - A2*1.1")
60		#'
61		#' @export
62
63		testGrowth <- function(ss = NULL, fit, test = "A") {
64	19x	method <- .specifyTestType(ss, test)
65	19x	if (method == "contrast") {
66	8x	res <- .nlhypothesis(fit, test, ss)
67	11x	} else if (method == "anova") {
68	11x	if (ss$model == "gam") {
69		#* do gam things
70	1x	if (ss$type == "nls") {
71	!	res <- .lmGamAnova(ss, fit)
72	1x	} else if (ss$type == "nlrq") {
73	!	res <- .rqGamAnova(ss, fit)
74	1x	} else if (ss$type == "nlme") {
75	!	res <- .lmeGamAnova(ss, fit)
76	1x	} else if (ss$type == "mgcv") {
77	1x	res <- .mgcvGamAnova(ss, fit)
78		}
79	10x	} else if (ss$type %in% c("nls", "nlme")) {
80	7x	res <- .nlsAnova(ss, fit, test_pars = test)
81	3x	} else if (ss$type == "nlrq") {
82	3x	if (any(test %in% c("A", "B", "C"))) {
83	3x	res <- .nlrqTest(ss, fit, test_pars = test)
84		}
85	!	} else if (grepl("surv", ss$type)) {
86	!	res <- .survTest(ss)
87		}
88		}
89
90	19x	return(res)
91		}
92
93		#' Helper function to specify type of testing to do
94		#' @examples
95		#' .specifyTestType(NULL, "anything") # survival test
96		#' .specifyTestType(list(), "A") # parameter anova test
97		#' .specifyTestType(list(), "A1 > A2") # contrast test
98		#' @keywords internal
99		#' @noRd
100
101		.specifyTestType <- function(ss, test) {
102	19x	if (!is.null(ss) && grepl("surv", ss$type)) {
103	!	test <- "S"
104		}
105	19x	if (all(unlist(lapply(test, nchar)) <= 2)) {
106	11x	method <- "anova"
107		} else {
108	8x	method <- "contrast"
109		}
110	19x	return(method)
111		}
112
113		#' (non)linear hypothesis function for nls and nlme models
114		#' @examples
115		#'
116		#' logistic_df <- growthSim("logistic",
117		#' n = 20, t = 25,
118		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
119		#' )
120		#' ss <- growthSS(
121		#' model = "logistic", form = y ~ time \| id / group,
122		#' df = logistic_df, type = "nls"
123		#' )
124		#' fit <- fitGrowth(ss)
125		#' .nlhypothesis(fit, test = list("A1 - A2", "B1-B2"))
126		#' .nlhypothesis(fit, test = "A1 + 10 - A2 * 1.1")
127		#' .nlhypothesis(fit, test = "A1/B1 - A2/B2")
128		#'
129		#' @keywords internal
130		#' @noRd
131
132		.nlhypothesis <- function(fit, test, ss) {
133	8x	if (methods::is(fit, "nlme")) {
134	2x	coefs <- nlme::fixef(fit)
135	6x	} else if (methods::is(fit, "nls")) {
136	4x	coefs <- stats::coef(fit)
137	2x	} else if (methods::is(fit, "brmsfit")) {
138	!	out <- brms::hypothesis(fit, test)
139	!	return(out)
140	2x	} else if (methods::is(fit, "nlrq") \|\| is.list(fit)) {
141	2x	out <- .nlrqTest2(ss, fit, test)
142	2x	return(out)
143		}
144	6x	dfresid <- summary(fit)$df[2]
145	6x	vcMat <- stats::vcov(fit)
146	6x	hypotheses <- data.frame(form = unlist(test))
147	6x	colnames(hypotheses) <- c("Form")
148	6x	val <- do.call(rbind, lapply(seq_len(nrow(hypotheses)), function(i) {
149	15x	car::deltaMethod(
150	15x	object = coefs, g = as.character(hypotheses$Form[i]),
151	15x	vcov. = vcMat, level = 0.95
152		)
153		}))
154	6x	row.names(val) <- seq_len(nrow(hypotheses))
155	6x	val <- cbind(hypotheses, val)
156	6x	lenVal <- ncol(val)
157	6x	out <- val[, 1:(lenVal - 2)]
158	6x	out$"t-value" <- abs(out$Estimate / out$SE)
159	6x	residualDF <- ifelse(is.null(dfresid), Inf, dfresid)
160	6x	out$"p-value" <- 2 * pt(out$"t-value", residualDF, lower.tail = FALSE)
161	2x	if (residualDF == Inf) colnames(out)[length(colnames(out)) - 1] <- "Z-value"
162	6x	return(out)
163		}
164
165
166
167		#' mgcv gam testing function
168		#' @examples
169		#'
170		#' logistic_df <- growthSim("logistic",
171		#' n = 20, t = 25,
172		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
173		#' )
174		#' ss <- growthSS(
175		#' model = "gam", form = y ~ time \| id / group,
176		#' df = logistic_df, type = "mgcv"
177		#' )
178		#' fit <- fitGrowth(ss)
179		#' .mgcvGamAnova(ss, fit)$anova
180		#'
181		#' @keywords internal
182		#' @noRd
183
184		.mgcvGamAnova <- function(ss, fit) {
185		#* `Get x variable`
186	1x	RHS <- as.character(ss$formula)[3]
187	1x	x <- sub(",", "", sub("s\\(", "", regmatches(RHS, regexpr("s\\(.*,", RHS))))
188	1x	ssNew <- ss
189		#* ***** `Make Null formula`
190	1x	ssNew$formula <- stats::as.formula(paste0("y ~ s(", x, ")"))
191		#* `rerun fitGrowth with new formula`
192	1x	nullMod <- fitGrowth(ssNew)
193		#* `compare models and return values`
194	1x	anv <- stats::anova(nullMod, fit, test = "F")
195	1x	out <- list("anova" = anv, "nullMod" = nullMod)
196	1x	return(out)
197		}
198
199
200
201		#' lme gam testing function
202		#' @examples
203		#'
204		#' logistic_df <- growthSim("logistic",
205		#' n = 20, t = 25,
206		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
207		#' )
208		#' ss <- growthSS(
209		#' model = "gam", form = y ~ time \| id / group,
210		#' df = logistic_df, type = "nlme"
211		#' )
212		#' fit <- fitGrowth(ss)
213		#' .lmeGamAnova(ss, fit)$anova
214		#'
215		#' @keywords internal
216		#' @noRd
217
218		.lmeGamAnova <- function(ss, fit) {
219		#* `Get x variable`
220	!	x <- trimws(sub("\\.", "", as.character(ss$formula$model)[3]))
221	!	ssNew <- ss
222		#* ***** `Make Null formulas`
223	!	newdf <- ss$df
224	!	newdf$dummy <- "A"
225	!	model_form <- ss$formula$model # fixed effects should be constant for likelihood testing
226		#* random effects formula
227	!	random_form <- stats::setNames(list(nlme::pdIdent(~ splines - 1, data = newdf)), "dummy")
228		#* variance formula
229	!	weights_form <- .nlme_sigma_form(as.list(ss$call)$sigma, x, "dummy")
230		#* correlation formula
231	!	correlation_form <- nlme::corAR1(0.8, form = stats::as.formula(paste0("~ 1 \| dummy")))
232		#* add all to newSS as list
233	!	ssNew$formula <- list(
234	!	"model" = model_form, "random" = random_form,
235	!	"weights" = weights_form, "cor_form" = correlation_form
236		)
237	!	ssNew$df <- newdf
238		#* `rerun fitGrowth with new formula`
239	!	nullMod <- fitGrowth(ssNew)
240		#* `compare models and return values`
241	!	anv <- stats::anova(nullMod, fit)
242	!	out <- list("anova" = anv, "nullMod" = nullMod)
243	!	return(out)
244		}
245
246
247		#' rq gam testing function for multiple taus
248		#' @examples
249		#'
250		#' logistic_df <- growthSim("logistic",
251		#' n = 20, t = 25,
252		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
253		#' )
254		#' ss <- growthSS(
255		#' model = "gam", form = y ~ time \| id / group,
256		#' df = logistic_df, type = "nlrq", tau = c(0.25, 0.5, 0.75)
257		#' )
258		#' fit <- fitGrowth(ss, cores = 3)
259		#' .rqGamAnova(ss, fit)$"0.25"$anova
260		#' .rqGamAnova(ss, fit[[1]])$anova
261		#'
262		#' @keywords internal
263		#' @noRd
264
265		.rqGamAnova <- function(ss, fit) {
266	!	if (methods::is(fit, "rq")) {
267	!	tau <- as.character(fit$tau)
268	!	fit <- stats::setNames(list(fit), tau)
269		}
270	!	taus <- names(fit)
271	!	res <- lapply(taus, function(tau) {
272	!	f <- fit[[tau]]
273		#* `remove grouping from ss$formula`
274	!	rhs <- as.character(ss$formula)[3]
275	!	newRhs <- trimws(sub("\\.", "", rhs))
276	!	newFormula <- stats::as.formula(paste0(as.character(ss$formula)[2], "~", newRhs))
277		#* `Make new SS object`
278	!	ssNew <- ss
279	!	ssNew$formula <- newFormula
280	!	ssNew$taus <- as.numeric(tau)
281		#* `rerun fitGrowth with new formula`
282	!	nullMod <- fitGrowth(ssNew)
283		#* `compare models and return values`
284	!	anv <- stats::anova(nullMod, f)
285	!	out <- list("anova" = anv, "nullMod" = nullMod)
286	!	return(out)
287		})
288	!	names(res) <- taus
289	!	if (length(res) == 1) {
290	!	res <- res[[1]]
291		}
292	!	return(res)
293		}
294
295		#' lm gam testing function
296		#' @examples
297		#'
298		#' logistic_df <- growthSim("logistic",
299		#' n = 20, t = 25,
300		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
301		#' )
302		#' ss <- growthSS(
303		#' model = "gam", form = y ~ time \| id / group,
304		#' df = logistic_df, type = "nls"
305		#' )
306		#' fit <- fitGrowth(ss)
307		#' .lmGamAnova(ss, fit)$anova
308		#'
309		#' @keywords internal
310		#' @noRd
311
312		.lmGamAnova <- function(ss, fit) {
313		#* `remove grouping from ss$formula`
314	!	rhs <- as.character(ss$formula)[3]
315	!	newRhs <- trimws(sub("\\.", "", rhs))
316	!	newFormula <- stats::as.formula(paste0(as.character(ss$formula)[2], "~", newRhs))
317		#* `Make new SS object`
318	!	ssNew <- ss
319	!	ssNew$formula <- newFormula
320		#* `rerun fitGrowth with new formula`
321	!	nullMod <- fitGrowth(ssNew)
322		#* `compare models and return values`
323	!	anv <- stats::anova(nullMod, fit)
324	!	out <- list("anova" = anv, "nullMod" = nullMod)
325	!	return(out)
326		}
327
328
329		#' nls and nlme testing function
330		#' @examples
331		#'
332		#' logistic_df <- growthSim("logistic",
333		#' n = 20, t = 25,
334		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
335		#' )
336		#' ss <- growthSS(
337		#' model = "logistic", form = y ~ time \| id / group,
338		#' df = logistic_df, type = "nls"
339		#' )
340		#' fit <- fitGrowth(ss)
341		#' .nlsAnova(ss, fit, test_pars = "A")$anova
342		#' ss <- growthSS(
343		#' model = "logistic", form = y ~ time \| id / group,
344		#' df = logistic_df, type = "nlme"
345		#' )
346		#' fit <- fitGrowth(ss)
347		#' .nlsAnova(ss, fit, test_pars = "A")$anova
348		#'
349		#' @keywords internal
350		#' @noRd
351
352		.nlsAnova <- function(ss, fit, test_pars = "A") {
353		#* `Get parameters to vary in comparison model`
354	7x	xForm <- as.character(ss$formula)[3]
355	7x	rMatches <- gregexpr(".2?\\[", xForm)
356	7x	original_grouped_pars <- sub("\\[", "", regmatches(xForm, rMatches)[[1]])
357	7x	null_pars <- original_grouped_pars[!original_grouped_pars %in% test_pars]
358		#* `match call for previous model, updating pars`
359	7x	lcall <- as.list(ss$call)
360	7x	lcall$pars <- null_pars
361	7x	lcall$df <- ss$df
362	7x	new_call <- as.call(lcall)
363		#* `rerun growthSS and fitGrowth with updated parameters`
364	7x	nullSS <- suppressMessages(eval(new_call))
365	7x	nullMod <- fitGrowth(nullSS)
366		#* `compare models and return values`
367	7x	anv <- stats::anova(nullMod, fit)
368	7x	out <- list("anova" = anv, "nullMod" = nullMod)
369	7x	return(out)
370		}
371
372		#' pseudo LRT function for nlrq
373		#' @examples
374		#'
375		#' logistic_df <- growthSim("logistic",
376		#' n = 20, t = 25,
377		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
378		#' )
379		#' ss <- growthSS(
380		#' model = "logistic", form = y ~ time \| id / group,
381		#' df = logistic_df, type = "nlrq", tau = c(0.25, 0.5, 0.75)
382		#' )
383		#' fit <- fitGrowth(ss)
384		#' .nlrqTest(ss, fit, test_pars = "A")$anova
385		#'
386		#' @keywords internal
387		#' @noRd
388
389		.nlrqTest <- function(ss, fit, test_pars = "A") {
390		#* `Get parameters to vary in comparison model`
391	3x	xForm <- as.character(ss$formula)[3]
392	3x	rMatches <- gregexpr(".2?\\[", xForm)
393	3x	original_grouped_pars <- sub("\\[", "", regmatches(xForm, rMatches)[[1]])
394	3x	null_pars <- original_grouped_pars[!original_grouped_pars %in% test_pars]
395		#* `match call for previous model, updating pars`
396	3x	lcall <- as.list(ss$call)
397	3x	lcall$pars <- null_pars
398	3x	lcall$df <- ss$df
399	3x	new_call <- as.call(lcall)
400		#* `rerun growthSS and fitGrowth with updated parameters`
401	3x	nullSS <- suppressMessages(eval(new_call))
402	3x	nullMods <- fitGrowth(nullSS)
403	3x	if (methods::is(fit, "nlrq")) {
404	1x	fit <- list(fit)
405	1x	names(fit) <- ss$taus
406	1x	nullMods <- list(nullMods)
407	1x	names(nullMods) <- ss$taus
408		}
409
410		#* `arrange models for comparisons`
411
412	3x	modsList <- lapply(ss$taus, function(tau) list(fit[[paste0(tau)]], nullMods[[paste0(tau)]]))
413
414	3x	res <- lapply(modsList, function(modsPair) {
415	28x	.nlrqPseudoLRT(modsPair)
416		})
417	3x	names(res) <- ss$taus
418	3x	return(res)
419		}
420
421
422		#' pseudo LRT function for nlrq, aiming to use empirical likelihood given more time
423		#' @param nested_models list of models with the same tau generated by .nlrqTest
424		#' @keywords internal
425		#' @noRd
426
427		.nlrqPseudoLRT <- function(nested_models) {
428	28x	nModels <- length(nested_models) # currently always 2, but might change in the future.
429	28x	rval <- matrix(rep(NA, 5 * 2), ncol = 5)
430	28x	colnames(rval) <- c("#Df", "LogLik", "Df", "Chisq", "Pr(>Chisq)")
431	28x	rownames(rval) <- 1:2
432	28x	logL <- lapply(nested_models, stats::logLik)
433	28x	rval[, 1] <- as.numeric(sapply(logL, function(x) attr(x, "df")))
434	28x	rval[, 2] <- sapply(logL, as.numeric)
435	28x	rval[2:nModels, 3] <- rval[2:nModels, 1] - rval[1:(nModels - 1), 1]
436	28x	rval[2:nModels, 4] <- 2 * abs(rval[2:nModels, 2] - rval[1:(nModels - 1), 2])
437	28x	rval[, 5] <- stats::pchisq(rval[, 4], round(abs(rval[, 3])), lower.tail = FALSE)
438
439	28x	variables <- lapply(nested_models, function(x) {
440	56x	deparse(as.list(stats::getCall(x))$formula)
441		})
442	28x	header <- paste("Model ", format(1:nModels), ": ", variables, sep = "", collapse = "\n")
443	28x	out <- structure(as.data.frame(rval),
444	28x	heading = header,
445	28x	class = c("anova", "data.frame")
446		)
447	28x	return(out)
448		}
449
450
451		#' Parameterized test for nlrq models using SE
452		#' @examples
453		#' logistic_df <- growthSim("logistic",
454		#' n = 20, t = 25,
455		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
456		#' )
457		#' ss <- growthSS(
458		#' model = "logistic", form = y ~ time \| id / group,
459		#' df = logistic_df, type = "nlrq", tau = c(0.25, 0.5, 0.75)
460		#' )
461		#' fit <- fitGrowth(ss)
462		#' .nlrqTest2(ss, fit, test_pars = "a\|0.5\|A > b\|0.5\|A")
463		#' @keywords internal
464		#' @noRd
465
466		.nlrqTest2 <- function(ss, fit, test_pars = "a\|0.5\|A > b\|0.5\|A") {
467		#* `Get parameters to vary in comparison model`
468	2x	xForm <- as.character(ss$formula)[3]
469		#* `Get name of grouping variable in formula`
470	2x	rMatches2 <- regexpr("\\[[a-zA-Z0-9.]*\\]", xForm)
471	2x	groupVar <- sub("\\]", "", sub("\\[", "", regmatches(xForm, rMatches2)))
472		#* `parse test_pars formula`
473	2x	split_form <- lapply(strsplit(test_pars, ">\|<")[[1]], function(s) {
474	4x	stats::setNames(strsplit(trimws(s), "\\\|")[[1]], c("group", "tau", "par"))
475		})
476	2x	direction <- ifelse(grepl(">", test_pars), "greater", "lesser")
477		#* `select models based on tau`
478	2x	if (!methods::is(fit, "nlrq")) {
479	1x	fit1 <- fit[[split_form[[1]]["tau"]]]
480	1x	fit2 <- fit[[split_form[[2]]["tau"]]]
481	1x	fits <- list(fit1, fit2)
482		} else {
483	1x	fits <- list(fit, fit)
484		}
485		#* `get model data for each group in formula`
486	2x	mdf <- do.call(rbind, lapply(seq_along(split_form), function(i) {
487	4x	sf <- split_form[[i]]
488		#* `get model parameters`
489	4x	mdf <- as.data.frame(summary(fits[[i]])$coefficients)
490		#* `replace 1-nGroups with sorted group names`
491	4x	mdf$par <- substr(rownames(mdf), 1, 1)
492	4x	mdf$numericGroup <- sub("^[A-C]", "", rownames(mdf))
493
494	4x	gNames <- stats::setNames(
495	4x	data.frame(sort(unique(ss$df[[groupVar]])), seq_along(unique(ss$df[[groupVar]]))),
496	4x	c(groupVar, "numericGroup")
497		)
498	4x	mdf <- merge(mdf, gNames, by = "numericGroup")
499	4x	return(mdf[
500	4x	mdf[[groupVar]] == sf[["group"]] & mdf[["par"]] == sf[["par"]],
501	4x	c("Value", "Std. Error", "t value", "Pr(>\|t\|)", "par", "group")
502		])
503		}))
504		#* `make T distributions for comparisons`
505	2x	support1 <- extraDistr::qlst(c(0.0001, 0.9999),
506	2x	df = 5, mu = mdf[1, "Value"],
507	2x	sigma = mdf[1, "Std. Error"]
508		)
509	2x	support2 <- extraDistr::qlst(c(0.0001, 0.9999),
510	2x	df = 5, mu = mdf[2, "Value"],
511	2x	sigma = mdf[2, "Std. Error"]
512		)
513	2x	mn <- 0.99 * min(c(support1, support2))
514	2x	mx <- 1.01 * max(c(support1, support2))
515	2x	support <- seq(mn, mx, length.out = 10000)
516	2x	t1 <- extraDistr::dlst(support, df = 5, mu = mdf[1, "Value"], sigma = mdf[1, "Std. Error"])
517	2x	t2 <- extraDistr::dlst(support, df = 5, mu = mdf[2, "Value"], sigma = mdf[2, "Std. Error"])
518	2x	pdf1 <- t1 / sum(t1)
519	2x	pdf2 <- t2 / sum(t2)
520	2x	res <- .post.prob.from.pdfs(pdf1, pdf2, direction)$post.prob
521	2x	mdf[[paste0("prob.", direction)]] <- c(res, NA)
522	2x	return(mdf)
523		}
524
525
526		#' Chisq based test for survreg and flexsurv models using SE
527		#' @examples
528		#'
529		#'
530		#' df <- growthSim("logistic",
531		#' n = 20, t = 25,
532		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
533		#' )
534		#' ss <- growthSS("survival weibull", y > 100 ~ time \| id / group, df = df, type = "survreg")
535		#' fit <- fitGrowth(ss)
536		#' .survTest(ss, fit)
537		#'
538		#' ss <- growthSS("survival weibull", y > 100 ~ time \| id / group, df = df, type = "flexsurv")
539		#' fit <- fitGrowth(ss)
540		#' .survTest(ss, fit)
541		#'
542		#' @keywords internal
543		#' @noRd
544
545		.survTest <- function(ss = NULL, fit = NULL) {
546	!	if (ss$type == "survreg") {
547	!	survival::survdiff(formula = ss$formula, data = ss$df)
548	!	} else if (ss$type == "flexsurv") {
549	!	x <- as.character(ss$pcvrForm)[3]
550	!	x3 <- trimws(strsplit(x, "[\|]\|[/]")[[1]])
551	!	group <- x3[length(x3)]
552	!	groups <- unique(ss$df[[group]])
553	!	at <- lapply(groups, function(i) stats::setNames(list(i), group))
554	!	as.data.frame(flexsurv::standsurv(fit, at = at, contrast = "difference", se = TRUE, ci = TRUE))
555		}
556		}

1		#' Function to visualize \code{quantreg::rq} general additive growth models.
2		#'
3		#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
4		#' (and similar models made through other means) can be visualized easily using this function.
5		#' This will generally be called by \code{growthPlot}.
6		#'
7		#' @param fit A model fit, or list of model fits, returned by \code{fitGrowth}
8		#' with type="nlrq" and model="gam".
9		#' @param form A formula similar to that in \code{growthSS} inputs (or the \code{pcvrForm}
10		#' part of the output) specifying the outcome,
11		#' predictor, and grouping structure of the data as \code{outcome ~ predictor\|individual/group}.
12		#' If the individual and group are specified then the observed growth lines are plotted.
13		#' @param df A dataframe to use in plotting observed growth curves on top of the model.
14		#' This must be supplied for rq models.
15		#' @param groups An optional set of groups to keep in the plot.
16		#' Defaults to NULL in which case all groups in the model are plotted.
17		#' @param timeRange An optional range of times to use. This can be used to view predictions for
18		#' future data if the avaiable data has not reached some point (such as asymptotic size).
19		#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
20		#' @param groupFill logical, should groups have different colors? Defaults to FALSE.
21		#' If TRUE then viridis colormaps are used in the order of virMaps
22		#' @param virMaps order of viridis maps to use. Will be recycled to necessary length.
23		#' Defaults to "plasma", but will generally be informed by growthPlot's default.
24		#' @keywords growth-curve
25		#' @importFrom methods is
26		#' @import ggplot2
27		#' @importFrom stats setNames predict
28		#' @importFrom viridis plasma
29		#' @examples
30		#'
31		#'
32		#' simdf <- growthSim("logistic",
33		#' n = 20, t = 25,
34		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
35		#' )
36		#' ss <- growthSS(
37		#' model = "gam", form = y ~ time \| id / group,
38		#' tau = c(0.25, 0.5, 0.75), df = simdf, start = NULL, type = "nlrq"
39		#' )
40		#' fits <- fitGrowth(ss)
41		#' rqPlot(fits, form = ss$pcvrForm, df = ss$df, groupFill = TRUE)
42		#' rqPlot(fits, form = ss$pcvrForm, df = ss$df, groups = "a", timeRange = 1:10)
43		#'
44		#' ss <- growthSS(
45		#' model = "gam", form = y ~ time \| group,
46		#' tau = c(0.5), df = simdf, start = NULL, type = "nlrq"
47		#' )
48		#' fit <- fitGrowth(ss)
49		#' rqPlot(fit, form = ss$pcvrForm, df = ss$df, groupFill = TRUE)
50		#'
51		#' @return Returns a ggplot showing an rq general additive model's quantiles
52		#' and optionally the individual growth lines.
53		#'
54		#' @export
55
56		rqPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE,
57		groupFill = FALSE, virMaps = c("plasma")) {
58		#* `get needed information from formula`
59	3x	parsed_form <- .parsePcvrForm(form, df)
60		#* `pick longitudinal or non-longitudinal helper`
61	3x	if (!is.numeric(df[, parsed_form$x]) && !parsed_form$USEG && !parsed_form$USEID) {
62	!	p <- .rqStaticPlot(
63	!	fit, form, df, groups, timeRange,
64	!	facetGroups, groupFill, virMaps, parsed_form
65		)
66	!	return(p)
67		}
68	3x	p <- .rqLongitudinalPlot(
69	3x	fit, form, df, groups, timeRange,
70	3x	facetGroups, groupFill, virMaps, parsed_form
71		)
72	3x	return(p)
73		}
74
75		#' @keywords internal
76		#' @noRd
77
78		.rqStaticPlot <- function(fit, form, df, groups, timeRange,
79		facetGroups, groupFill, virMaps, parsed_form) {
80	!	x <- parsed_form$x
81	!	df <- parsed_form$data
82
83	!	if (methods::is(fit, "rq")) {
84	!	fit <- list(fit)
85		}
86
87	!	summary_df <- do.call(rbind, lapply(fit, function(model) {
88	!	iter_df <- as.data.frame(coef(summary(model)))
89	!	colnames(iter_df) <- c("est", "err", "t", "p")
90	!	iter_df[[x]] <- rownames(iter_df)
91	!	iter_df[1, x] <- paste0(x, unique(df[[x]])[1])
92	!	iter_df[["est"]] <- cumsum(iter_df[["est"]])
93	!	iter_df$tau <- model$tau
94	!	iter_df
95		}))
96
97		#* `filter by groups if groups != NULL`
98	!	if (!is.null(groups)) {
99	!	summary_df <- summary_df[summary_df[[x]] %in% groups, ]
100		}
101		#* `facetGroups`
102	!	facet_layer <- NULL
103	!	if (facetGroups) {
104	!	facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", x)),
105	!	scales = "free_x"
106		)
107		}
108		#* `groupFill`
109	!	n_taus <- length(unique(summary_df$tau))
110	!	if (groupFill) {
111	!	virList <- lapply(rep(virMaps, length.out = length(unique(summary_df[[x]]))), function(pal) {
112	!	virpal_p1 <- viridis::viridis(ceiling(n_taus / 2),
113	!	direction = 1, end = 1, option = pal
114		)
115	!	virpal_p2 <- viridis::viridis(ceiling(n_taus / 2),
116	!	direction = -1, end = 1, option = pal
117	!	)[-1]
118	!	c(virpal_p1, virpal_p2)
119		})
120		} else {
121	!	virpal_p1 <- viridis::plasma(ceiling(n_taus / 2), direction = 1, end = 1)
122	!	virpal_p2 <- viridis::plasma(ceiling(n_taus / 2), direction = -1, end = 1)[-1]
123	!	virpal <- c(virpal_p1, virpal_p2)
124	!	virList <- lapply(seq_along(unique(summary_df[[x]])), function(i) {
125	!	virpal
126		})
127		}
128		#* `plot`
129	!	plot <- ggplot(summary_df, ggplot2::aes(group = interaction(.data[[x]]))) +
130	!	facet_layer +
131	!	labs(x = x, y = as.character(form)[2]) +
132	!	pcv_theme()
133
134	!	for (g in seq_along(unique(summary_df[[x]]))) {
135	!	iteration_group <- unique(summary_df[[x]])[g]
136	!	sub <- summary_df[summary_df[[x]] == iteration_group, ]
137	!	for (i in seq_along(unique(sub$tau))) {
138	!	inner_sub <- sub[sub$tau == unique(sub$tau)[i], ]
139	!	plot <- plot +
140	!	ggplot2::geom_errorbar(data = inner_sub, ggplot2::aes(
141	!	x = .data[[x]],
142	!	ymin = .data[["est"]] - 2 * .data[["err"]],
143	!	ymax = .data[["est"]] + 2 * .data[["err"]]
144	!	), width = 0.15, color = virList[[g]][i]) +
145	!	ggplot2::geom_point(
146	!	data = inner_sub, ggplot2::aes(
147	!	x = .data[[x]],
148	!	y = .data[["est"]]
149		),
150	!	color = virList[[g]][i], size = 4
151		) +
152	!	ggplot2::geom_text(
153	!	data = inner_sub, ggplot2::aes(
154	!	x = .data[[x]],
155	!	y = .data[["est"]],
156	!	label = .data[["tau"]]
157		),
158	!	size = 2, color = "white"
159		)
160		}
161		}
162	!	plot
163	!	return(plot)
164		}
165
166		#' @keywords internal
167		#' @noRd
168
169		.rqLongitudinalPlot <- function(fit, form, df, groups, timeRange,
170		facetGroups, groupFill, virMaps, parsed_form) {
171	3x	y <- parsed_form$y
172	3x	x <- parsed_form$x
173	3x	individual <- parsed_form$individual
174	3x	if (individual == "dummyIndividual") {
175	1x	individual <- NULL
176		}
177	3x	group <- parsed_form$group
178	3x	df <- parsed_form$data
179		#* `filter by groups if groups != NULL`
180	3x	if (!is.null(groups)) {
181	1x	df <- df[df[[group]] %in% groups, ]
182		}
183		#* `make new data if timerange is not NULL`
184	3x	if (!is.null(timeRange)) {
185	1x	new_data <- do.call(rbind, lapply(unique(df[[group]]), function(g) {
186	1x	stats::setNames(data.frame(g, timeRange), c(group, x))
187		}))
188	1x	df <- df[df[[x]] >= min(timeRange) & df[[x]] <= max(timeRange), ]
189		} else {
190	2x	new_data <- df
191		}
192		#* `standardize fit class`
193	3x	if (methods::is(fit, "rq")) {
194	1x	fit <- list(fit)
195	1x	names(fit) <- fit$tau
196		}
197		#* `add predictions and record taus`
198	3x	preds <- do.call(cbind, lapply(fit, function(f) {
199	7x	tau <- f$tau
200	7x	stats::setNames(data.frame(stats::predict(f, newdata = new_data)), paste0("Q_", tau))
201		}))
202	3x	predCols <- colnames(preds)
203	3x	keep <- which(!duplicated(preds))
204	3x	plotdf <- cbind(df[keep, ], preds[keep, ])
205	3x	colnames(plotdf) <- c(colnames(df), colnames(preds))
206		#* `layer for individual lines if formula was complete`
207	3x	individual_lines <- list()
208	3x	if (!is.null(individual)) {
209	2x	individual_lines <- ggplot2::geom_line(
210	2x	data = df, ggplot2::aes(
211	2x	x = .data[[x]], y = .data[[y]],
212	2x	group = interaction(
213	2x	.data[[individual]],
214	2x	.data[[group]]
215		)
216		),
217	2x	linewidth = 0.25, color = "gray40"
218		)
219		}
220		#* `facetGroups`
221	3x	facet_layer <- NULL
222	3x	if (facetGroups) {
223	3x	facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
224		}
225		#* `groupFill`
226	3x	if (groupFill) {
227	2x	virList <- lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
228	4x	virpal_p1 <- viridis::viridis(ceiling(length(predCols) / 2), direction = 1, end = 1, option = pal)
229	4x	virpal_p2 <- viridis::viridis(ceiling(length(predCols) / 2),
230	4x	direction = -1, end = 1, option = pal
231	4x	)[-1]
232	4x	c(virpal_p1, virpal_p2)
233		})
234		} else {
235	1x	virpal_p1 <- viridis::plasma(ceiling(length(predCols) / 2), direction = 1, end = 1)
236	1x	virpal_p2 <- viridis::plasma(ceiling(length(predCols) / 2), direction = -1, end = 1)[-1]
237	1x	virpal <- c(virpal_p1, virpal_p2)
238	1x	virList <- lapply(seq_along(unique(df[[group]])), function(i) {
239	1x	virpal
240		})
241		}
242		#* `plot`
243	3x	plot <- ggplot(plotdf, ggplot2::aes(group = interaction(.data[[group]]))) +
244	3x	facet_layer +
245	3x	individual_lines +
246	3x	labs(x = x, y = as.character(form)[2]) +
247	3x	pcv_theme()
248
249	3x	for (g in seq_along(unique(plotdf[[group]]))) {
250	5x	iteration_group <- unique(plotdf[[group]])[g]
251	5x	sub <- plotdf[plotdf[[group]] == iteration_group, ]
252	5x	plot <- plot +
253	5x	lapply(seq_along(predCols), function(i) {
254	11x	ggplot2::geom_line(
255	11x	data = sub, ggplot2::aes(x = .data[[x]], y = .data[[predCols[i]]]),
256	11x	color = virList[[g]][i], linewidth = 0.7
257		)
258		})
259		}
260	3x	return(plot)
261		}

1		#' Function to visualize common \code{stats::nls} growth models.
2		#'
3		#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
4		#' (and similar models made through other means) can be visualized easily using this function.
5		#' This will generally be called by \code{growthPlot}.
6		#'
7		#' @param fit A model fit returned by \code{fitGrowth} with type="nls".
8		#' @param form A formula similar to that in \code{growthSS} inputs (or the \code{pcvrForm}
9		#' part of the output) specifying the outcome, predictor, and grouping structure of the data as
10		#' \code{outcome ~ predictor\|individual/group}.
11		#' If the individual and group are specified then the observed growth lines are plotted.
12		#' @param groups An optional set of groups to keep in the plot.
13		#' Defaults to NULL in which case all groups in the model are plotted.
14		#' @param df A dataframe to use in plotting observed growth curves on top of the model.
15		#' This must be supplied for nls models.
16		#' @param timeRange An optional range of times to use. This can be used to view predictions for
17		#' future data if the avaiable data has not reached some point (such as asymptotic size).
18		#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
19		#' @param groupFill logical, should groups have different colors? Defaults to FALSE.
20		#' If TRUE then viridis colormaps are used in the order of virMaps
21		#' @param virMaps order of viridis maps to use. Will be recycled to necessary length.
22		#' Defaults to "plasma", but will generally be informed by growthPlot's default.
23		#' @keywords growth-curve
24		#' @importFrom methods is
25		#' @import ggplot2
26		#' @importFrom stats predict
27		#' @examples
28		#'
29		#'
30		#' simdf <- growthSim("logistic",
31		#' n = 20, t = 25,
32		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
33		#' )
34		#' ss <- growthSS(
35		#' model = "logistic", form = y ~ time \| id / group,
36		#' df = simdf, start = NULL, type = "nls"
37		#' )
38		#' fit <- fitGrowth(ss)
39		#' nlsPlot(fit, form = ss$pcvrForm, df = ss$df, groupFill = TRUE)
40		#' nlsPlot(fit, form = ss$pcvrForm, df = ss$df, groups = "a", timeRange = 1:10)
41		#'
42		#' @return Returns a ggplot showing an nls model's predictions.
43		#'
44		#' @export
45
46		nlsPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL,
47		facetGroups = TRUE, groupFill = FALSE, virMaps = c("plasma")) {
48		#* `get needed information from formula`
49	7x	parsed_form <- .parsePcvrForm(form, df)
50		#* `pick longitudinal or non-longitudinal helper`
51	7x	if (!is.numeric(df[, parsed_form$x]) && !parsed_form$USEG && !parsed_form$USEID) {
52	!	p <- .nlsStaticPlot(
53	!	fit, form, df, groups, timeRange,
54	!	facetGroups, groupFill, virMaps, parsed_form
55		)
56	!	return(p)
57		}
58	7x	p <- .nlsLongitudinalPlot(
59	7x	fit, form, df, groups, timeRange,
60	7x	facetGroups, groupFill, virMaps, parsed_form
61		)
62	7x	return(p)
63		}
64
65		#' @keywords internal
66		#' @noRd
67
68		.nlsStaticPlot <- function(fit, form, df, groups, timeRange,
69		facetGroups, groupFill, virMaps, parsed_form) {
70	!	x <- parsed_form$x
71	!	df <- parsed_form$data
72		#* `when implemented SE can be added here, see ?predict.nls`
73	!	summary_df <- as.data.frame(coef(summary(mod1)))
74	!	colnames(summary_df) <- c("est", "err", "t", "p")
75	!	summary_df[[x]] <- rownames(summary_df)
76	!	summary_df[1, x] <- paste0(x, unique(df[[x]])[1])
77	!	summary_df[["est"]] <- cumsum(summary_df[["est"]])
78		#* `filter by groups if groups != NULL`
79	!	if (!is.null(groups)) {
80	!	summary_df <- summary_df[summary_df[[x]] %in% groups, ]
81		}
82		#* `facetGroups`
83	!	facet_layer <- NULL
84	!	if (facetGroups) {
85	!	facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", x)))
86		}
87		#* `groupFill`
88	!	if (groupFill) {
89	!	virVals <- unlist(lapply(
90	!	rep(virMaps, length.out = length(unique(summary_df[[x]]))),
91	!	function(pal) {
92	!	viridis::viridis(1, begin = 0.5, option = pal)
93		}
94		))
95	!	color_scale <- ggplot2::scale_color_manual(values = virVals)
96		} else {
97	!	color_scale <- ggplot2::scale_color_manual(values = rep("#CC4678FF", length(unique(df[[x]]))))
98		}
99		#* `plot`
100	!	plot <- ggplot(summary_df, ggplot2::aes(group = interaction(.data[[x]]))) +
101	!	facet_layer +
102	!	ggplot2::geom_errorbar(ggplot2::aes(
103	!	x = .data[[x]],
104	!	ymin = .data[["est"]] - 2 * .data[["err"]],
105	!	ymax = .data[["est"]] + 2 * .data[["err"]]
106	!	), width = 0.25) +
107	!	ggplot2::geom_point(ggplot2::aes(x = .data[[x]], y = .data[["est"]], color = .data[[x]]),
108	!	size = 4
109		) +
110	!	color_scale +
111	!	labs(x = x, y = as.character(form)[2]) +
112	!	pcv_theme()
113	!	return(plot)
114		}
115
116		#' @keywords internal
117		#' @noRd
118
119		.nlsLongitudinalPlot <- function(fit, form, df, groups, timeRange,
120		facetGroups, groupFill, virMaps, parsed_form) {
121	7x	y <- parsed_form$y
122	7x	x <- parsed_form$x
123	7x	individual <- parsed_form$individual
124	7x	if (individual == "dummyIndividual") {
125	!	individual <- NULL
126		}
127	7x	group <- parsed_form$group
128	7x	df <- parsed_form$data
129		#* `filter by groups if groups != NULL`
130	7x	if (!is.null(groups)) {
131	1x	df <- df[df[[group]] %in% groups, ]
132		}
133		#* `make new data if timerange is not NULL`
134	7x	if (!is.null(timeRange)) {
135	1x	new_data <- do.call(rbind, lapply(unique(df[[group]]), function(g) {
136	1x	stats::setNames(data.frame(g, timeRange), c(group, x))
137		}))
138	1x	df <- df[df[[x]] >= min(timeRange) & df[[x]] <= max(timeRange), ]
139		} else {
140	6x	new_data <- NULL
141		}
142		#* `add predictions`
143
144	7x	preds <- data.frame(pred = stats::predict(fit, newdata = new_data))
145	7x	keep <- which(!duplicated(preds$pred))
146	7x	plotdf <- df[keep, ]
147	7x	plotdf$pred <- preds[keep, "pred"]
148
149		#* `when implemented SE can be added here, see ?predict.nls`
150		#*
151		#* `layer for individual lines if formula was complete`
152	7x	individual_lines <- list()
153	7x	if (!is.null(individual)) {
154	7x	individual_lines <- ggplot2::geom_line(
155	7x	data = df, ggplot2::aes(
156	7x	x = .data[[x]], y = .data[[y]],
157	7x	group = interaction(
158	7x	.data[[individual]],
159	7x	.data[[group]]
160		)
161		),
162	7x	linewidth = 0.25, color = "gray40"
163		)
164		}
165		#* `facetGroups`
166	7x	facet_layer <- NULL
167	7x	if (facetGroups) {
168	7x	facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
169		}
170		#* `groupFill`
171	7x	if (groupFill) {
172	1x	virVals <- unlist(lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
173	2x	viridis::viridis(1, begin = 0.5, option = pal)
174		}))
175	1x	color_scale <- ggplot2::scale_color_manual(values = virVals)
176		} else {
177	6x	color_scale <- ggplot2::scale_color_manual(values = rep("#CC4678FF", length(unique(df[[group]]))))
178		}
179
180		#* `plot`
181	7x	plot <- ggplot(plotdf, ggplot2::aes(group = interaction(.data[[group]]))) +
182	7x	facet_layer +
183	7x	individual_lines +
184	7x	ggplot2::geom_line(ggplot2::aes(x = .data[[x]], y = .data[["pred"]], color = .data[[group]]),
185	7x	linewidth = 0.7
186	7x	) + # using middle of plasma pal
187	7x	color_scale +
188	7x	labs(x = x, y = as.character(form)[2]) +
189	7x	pcv_theme()
190
191	7x	return(plot)
192		}
193
194		#' @rdname nlsPlot
195		#' @examples
196		#' simdf <- growthSim("logistic",
197		#' n = 20, t = 25,
198		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
199		#' )
200		#' ss <- growthSS(
201		#' model = "gam", form = y ~ time \| id / group,
202		#' df = simdf, start = NULL, type = "nls"
203		#' )
204		#' fit <- fitGrowth(ss)
205		#' gamPlot(fit, form = ss$pcvrForm, df = ss$df, groupFill = TRUE)
206		#' gamPlot(fit, form = ss$pcvrForm, df = ss$df, groups = "a", timeRange = 1:10)
207		#' ss <- growthSS(
208		#' model = "gam", form = y ~ time \| group,
209		#' df = simdf, start = NULL, type = "nls"
210		#' )
211		#' fit <- fitGrowth(ss)
212		#' gamPlot(fit, form = ss$pcvrForm, df = ss$df, groupFill = TRUE)
213		#'
214		#' @export
215
216		gamPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE,
217		groupFill = FALSE, virMaps = c("plasma")) {
218		#* `get needed information from formula`
219	4x	parsed_form <- .parsePcvrForm(form, df)
220	4x	y <- parsed_form$y
221	4x	x <- parsed_form$x
222	4x	individual <- parsed_form$individual
223	4x	if (individual == "dummyIndividual") {
224	1x	individual <- NULL
225		}
226	4x	group <- parsed_form$group
227	4x	df <- parsed_form$data
228		#* `filter by groups if groups != NULL`
229	4x	if (!is.null(groups)) {
230	1x	df <- df[df[[group]] %in% groups, ]
231		}
232		#* `make new data if timerange is not NULL`
233	4x	if (!is.null(timeRange)) {
234	1x	new_data <- do.call(rbind, lapply(unique(df[[group]]), function(g) {
235	1x	stats::setNames(data.frame(g, timeRange), c(group, x))
236		}))
237		} else {
238		# note this is the only change between this and nlsPlot
239		# this change is here because predict.nls sometimes acts strangely with the given data
240		# but predict.gam does not accept a NULL input for the newdata argument.
241	3x	new_data <- df
242		}
243		#* `add predictions`
244
245	4x	preds <- data.frame(pred = stats::predict(fit, newdata = new_data))
246	4x	keep <- which(!duplicated(preds$pred))
247	4x	plotdf <- df[keep, ]
248	4x	plotdf$pred <- preds[keep, "pred"]
249
250		#* `when implemented SE can be added here, see ?predict.nls`
251		#*
252		#* `layer for individual lines if formula was complete`
253	4x	individual_lines <- list()
254	4x	if (!is.null(individual)) {
255	3x	individual_lines <- ggplot2::geom_line(
256	3x	data = df, ggplot2::aes(
257	3x	x = .data[[x]], y = .data[[y]],
258	3x	group = interaction(
259	3x	.data[[individual]],
260	3x	.data[[group]]
261		)
262		),
263	3x	linewidth = 0.25, color = "gray40"
264		)
265		}
266		#* `facetGroups`
267	4x	facet_layer <- NULL
268	4x	if (facetGroups) {
269	4x	facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
270		}
271		#* `groupFill`
272	4x	if (groupFill) {
273	2x	virVals <- unlist(lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
274	4x	viridis::viridis(1, begin = 0.5, option = pal)
275		}))
276	2x	color_scale <- ggplot2::scale_color_manual(values = virVals)
277		} else {
278	2x	color_scale <- ggplot2::scale_color_manual(values = rep("#CC4678FF", length(unique(df[[group]]))))
279		}
280
281		#* `plot`
282	4x	plot <- ggplot(plotdf, ggplot2::aes(group = interaction(.data[[group]]))) +
283	4x	facet_layer +
284	4x	individual_lines +
285	4x	ggplot2::geom_line(ggplot2::aes(x = .data[[x]], y = .data[["pred"]], color = .data[[group]]),
286	4x	linewidth = 0.7
287	4x	) + # using middle of plasma pal
288	4x	color_scale +
289	4x	labs(x = x, y = as.character(form)[2]) +
290	4x	pcv_theme()
291
292	4x	return(plot)
293		}
294
295		#' @rdname nlsPlot
296		#' @examples
297		#' simdf <- growthSim("logistic",
298		#' n = 20, t = 25,
299		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
300		#' )
301		#' ss <- growthSS(
302		#' model = "gam", form = y ~ time \| id / group,
303		#' df = simdf, start = NULL, type = "nls"
304		#' )
305		#' fit <- fitGrowth(ss)
306		#' lmPlot(fit, form = ss$pcvrForm, df = ss$df)
307		#' @export
308
309		lmPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE,
310		groupFill = FALSE, virMaps = c("plasma")) {
311	1x	nlsPlot(fit, form, df, groups, timeRange, facetGroups, groupFill, virMaps)
312		}

1		#' Helper function for parsing pcvr formulas used in growthSS and downstream functions
2		#'
3		#' @param form The pcvr style formula specifying outcome, predictor, individuals, and groups.
4		#' @param df The data that will be used to fit the model
5		#'
6		#' @keywords internal
7		#' @noRd
8
9		.parsePcvrForm <- function(form, df = NULL) {
10		#* `parse form argument`
11	158x	y <- as.character(form)[2]
12	158x	x <- as.character(form)[3]
13	158x	USEGROUP <- FALSE
14	158x	if (grepl("\\\|", x) && grepl("\\/", x)) { # Y ~ X per id within group
15	146x	x3 <- trimws(strsplit(x, "[\|]\|[/]")[[1]])
16	146x	x <- x3[1]
17	146x	individual <- x3[2]
18	146x	group <- x3[length(x3)]
19	146x	USEINDIVIDUAL <- TRUE
20	146x	if (!is.null(df)) {
21	146x	if (length(unique(df[[group]])) == 1) {
22	6x	USEGROUP <- FALSE
23		} else {
24	140x	USEGROUP <- TRUE
25		} # if there is only one group then ignore grouping
26		}
27	12x	} else if (grepl("\\\|", x)) { # Y ~ X by group
28	10x	x2 <- trimws(strsplit(x, "[\|]")[[1]])
29	10x	x <- x2[1]
30	10x	individual <- "dummyIndividual"
31	10x	df[[individual]] <- "dummyIndividual"
32	10x	group <- x2[length(x2)]
33	10x	USEGROUP <- TRUE
34	10x	USEINDIVIDUAL <- FALSE
35		} else { # Y ~ X
36	2x	x2 <- trimws(strsplit(x, "[\|]")[[1]])
37	2x	x <- x2[1]
38	2x	individual <- "dummyIndividual"
39	2x	group <- "dummyGroup"
40	2x	if (!is.null(df)) {
41	2x	df[[individual]] <- "dummyIndividual"
42	2x	df[[group]] <- "dummyGroup"
43		}
44	2x	USEGROUP <- FALSE
45	2x	USEINDIVIDUAL <- FALSE
46		}
47	158x	if (grepl("\\+", x)) {
48	1x	x_components <- lapply(strsplit(x, "\\+"), trimws)
49	1x	x <- x_components[[1]][1]
50	1x	hierarchical_predictor <- x_components[[1]][2]
51		} else {
52	157x	hierarchical_predictor <- NULL
53		}
54	158x	if (!is.null(df)) {
55	158x	tryCatch(
56		{
57	158x	df <- df[complete.cases(df[, c(x, y, individual, group)]), ]
58		},
59	158x	error = function(err) {}
60		)
61		}
62	158x	return(list(
63	158x	"y" = y, "x" = x, "individual" = individual, "group" = group,
64	158x	"USEG" = USEGROUP, "USEID" = USEINDIVIDUAL, "data" = df,
65	158x	"hierarchical_predictor" = hierarchical_predictor
66		))
67		}

1		#' Earth Mover's Distance between spectral histograms
2		#'
3		#' @description pcv.emd can be used to calculate Earth Mover's Distance between pairwise histograms
4		#' in a wide dataframe of multi value traits. The is expected to be used with output from \code{mv_ag}.
5		#' See also \link{pcv.euc} for euclidean distance between histograms.
6		#'
7		#' @param df Data frame to use with multi value traits in wide format or long format
8		#' @param cols Columns to use. Defaults to NULL in which case all columns are used.
9		#' Single strings will be used to regex a pattern in column names (see examples).
10		#' A vector of names, positions, or booleans will also work.
11		#' For long data this is taken as a regex pattern (or full name)
12		#' to use in filtering the trait column.
13		#' @param reorder Should data be reordered to put similar rows together in the resulting plot?
14		#' This takes a vector of column names of length 1 or more (see examples).
15		#' @param include if a long dataframe is returned then these columns will be added to the dataframe,
16		#' labelled for i and j (the row positions for compared histograms).
17		#' If a matrix is returned then this information is stored in the row names.
18		#' This defaults to reorder.
19		#' @param mat Logical, should data be returned as an nrow x nrow matrix or as a long dataframe?
20		#' By Default this is FALSE and a long dataframe is returned.
21		#' Both options are comparable in terms of speed,
22		#' although for large datasets the matrix version may be slightly faster.
23		#' @param plot Logical, should a plot be returned? For a matrix this is made with heatmap(),
24		#' for a dataframe this uses ggplot.
25		#' @param parallel Number of cores to use. Defaults to 1 unless the "mc.cores" option is set.
26		#' @param trait Column name for long data to identify traits. This defaults to "trait". If this and
27		#' value are in the column names of the data then it is assumed to be in long format,
28		#' otherwise it is assumed to be in wide format.
29		#' @param id A vector of column names that uniquely identifies observations if the
30		#' data is in long format. Defaults to "image".
31		#' @param value A column name for the values to be drawn from in long data.
32		#' Defaults to "value".
33		#' @param raiseError Logical, should warnings/errors be raised for potentially large output?
34		#' It is easy to ask for very many comparisons with this function so the goal of this argument
35		#' is to catch a few of those and give estimates of how much time something may take.
36		#' If the function is expected to take very long then a warning or an error is raised.
37		#' If this is set to FALSE then no time estimates are made.
38		#' @param method Which method to use (one of "emd" or "euc"). Defaults to "emd".
39		#' @import ggplot2
40		#' @import parallel
41		#' @return A dataframe/matrix (if plot=FALSE) or a list with a dataframe/matrix and\
42		#' a ggplot (if plot=TRUE). The returned data contains pairwise EMD values.
43		#'
44		#' @keywords emd earth-mover's-distance multi-value histogram
45		#' @examples
46		#'
47		#'
48		#' set.seed(123)
49		#' test <- mvSim(
50		#' dists = list(
51		#' runif = list(min = 0, max = 100),
52		#' rnorm = list(mean = 90, sd = 20)
53		#' ),
54		#' n_samples = 10
55		#' )
56		#' test$meta1 <- rep(LETTERS[1:3], length.out = nrow(test))
57		#' test$meta2 <- rep(LETTERS[4:5], length.out = nrow(test))
58		#'
59		#' x <- pcv.emd(
60		#' df = test, cols = "sim", reorder = "group",
61		#' include = c("meta1", "meta2"), mat = FALSE,
62		#' plot = FALSE, parallel = 1
63		#' )
64		#' head(x)
65		#' x2 <- pcv.emd(
66		#' df = test, cols = "sim", reorder = "group",
67		#' include = c("meta1", "meta2"), mat = FALSE,
68		#' plot = FALSE, parallel = 1, method = "euc"
69		#' )
70		#' head(x2)
71		#'
72		#' \donttest{
73		#' library(data.table)
74		#' file <- paste0(
75		#' "https://media.githubusercontent.com/media/joshqsumner/",
76		#' "pcvrTestData/main/pcv4-multi-value-traits.csv"
77		#' )
78		#' df1 <- read.pcv(file, "wide", reader = "fread")
79		#'
80		#' df1$genotype <- substr(df1$barcode, 3, 5)
81		#' df1$genotype <- ifelse(df1$genotype == "002", "B73",
82		#' ifelse(df1$genotype == "003", "W605S",
83		#' ifelse(df1$genotype == "004", "MM", "Mo17")
84		#' )
85		#' )
86		#' df1$fertilizer <- substr(df1$barcode, 8, 8)
87		#' df1$fertilizer <- ifelse(df1$fertilizer == "A", "100",
88		#' ifelse(df1$fertilizer == "B", "50", "0")
89		#' )
90		#'
91		#' tryCatch(
92		#' {
93		#' w <- pcv.emd(df1,
94		#' cols = "hue_frequencies", reorder = c("fertilizer", "genotype"),
95		#' mat = FALSE, plot = TRUE, parallel = 1
96		#' )
97		#' },
98		#' error = function(err) {
99		#' message(err)
100		#' }
101		#' )
102		#'
103		#' # Note on computational complexity
104		#' # This scales as O^2, see the plot below for some idea
105		#' # of the time for different input data sizes.
106		#' emdTime <- function(x, n = 1) {
107		#' x^2 / n * 0.0023
108		#' }
109		#' plot(
110		#' x = c(18, 36, 54, 72, 108, 135), y = c(0.74, 2.89, 6.86, 10.99, 26.25, 42.44),
111		#' xlab = "N Input Images", ylab = "time (seconds)"
112		#' ) # benchmarked test data
113		#' lines(x = 1:150, y = emdTime(1:150)) # exponential function
114		#'
115		#' plot(
116		#' x = 1:1000, y = emdTime(1:1000), type = "l",
117		#' xlab = "N Input Images", ylab = "time (seconds)"
118		#' )
119		#' }
120		#'
121		#' @export
122		#'
123		pcv.emd <- function(df, cols = NULL, reorder = NULL, include = reorder, mat = FALSE, plot = TRUE,
124		parallel = getOption("mc.cores", 1), trait = "trait", id = "image",
125		value = "value", raiseError = TRUE, method = "emd") {
126	12x	if (all(c(trait, value) %in% colnames(df))) {
127	4x	long <- TRUE
128	4x	traitCol <- trait
129		} else {
130	8x	long <- FALSE
131		}
132	12x	if (!is.null(reorder)) {
133	8x	df <- df[order(interaction(df[, reorder])), ]
134		}
135	12x	if (long) {
136	4x	out_data <- .longEmdCalculation(
137	4x	df, cols, traitCol, raiseError,
138	4x	parallel, id, value, include, mat, method
139		)
140		} else { # wide input
141
142	8x	out_data <- .wideEmdCalculation(df, cols, raiseError, parallel, id, include, mat, method)
143		}
144	12x	if (plot) {
145	8x	if (mat) {
146	4x	p <- stats::heatmap(out_data)
147		} else {
148	4x	p <- ggplot2::ggplot(out_data, ggplot2::aes(x = .data$i, y = .data$j, fill = .data[[method]])) +
149	4x	ggplot2::geom_tile(color = NA) +
150	4x	ggplot2::labs(fill = method) +
151	4x	ggplot2::theme_minimal() +
152	4x	ggplot2::theme(
153	4x	axis.line.x.bottom = ggplot2::element_line(), axis.line.y.left = ggplot2::element_line(),
154	4x	legend.position = "bottom"
155		)
156		}
157	8x	outList <- list("data" = out_data, "plot" = p)
158		} else {
159	4x	outList <- out_data
160		}
161	12x	return(outList)
162		}
163
164
165		#' Error Raising function for very long EMD calculation times
166		#' @keywords internal
167		#' @noRd
168
169		.emdRaiseError <- function(raiseError, df, parallel, trait = NULL) {
170	15x	n <- ifelse(is.null(trait), nrow(df), nrow(df) / length(unique(df[[trait]])))
171	15x	if (raiseError) {
172	9x	et_sec <- 0.00125 * ((n / parallel)^2)
173	9x	et_min <- et_sec / 60
174	9x	et_hour <- et_min / 60
175	9x	if (et_sec <= 300) {
176	7x	message(paste0(
177	7x	"Estimated time of calculation is roughly ", round(et_sec, 1),
178	7x	" seconds using ", parallel, " cores in parallel."
179		))
180	2x	} else if (et_min < 60) {
181	1x	warning(paste0(
182	1x	"Estimated time of calculation is roughly ", round(et_min, 2),
183	1x	" minutes using ", parallel, " cores in parallel."
184		))
185	1x	} else if (et_min > 60) {
186	1x	stop(paste0(
187	1x	"Stopping, estimated time of calculation is roughly ", round(et_hour, 2),
188	1x	" hours using ", parallel, " cores in parallel.",
189	1x	"\nIf you wish to proceed then rerun this command with raiseError=FALSE"
190		))
191		}
192		}
193		}
194
195		#' Long EMD calculation
196		#' @keywords internal
197		#' @noRd
198
199		.longEmdCalculation <- function(df, cols, traitCol, raiseError, parallel, id,
200		value, include, mat, method) {
201	4x	dist_1d <- match.fun(paste0(method, "1d"))
202	4x	df <- df[grepl(cols, df[[traitCol]]), ]
203		#* `raise error`
204	4x	.emdRaiseError(raiseError, df, parallel, trait = traitCol)
205		#* `calculate emd`
206	4x	df$INNER_ID_EMD <- interaction(df[, id], drop = TRUE)
207	4x	if (mat) { # make dist matrix
208	2x	mat_obj <- matrix(0,
209	2x	nrow = length(unique(df$INNER_ID_EMD)),
210	2x	ncol = length(unique(df$INNER_ID_EMD))
211		)
212	2x	values <- unlist(lapply(seq_along(unique(df$INNER_ID_EMD)), function(i_n) {
213	40x	parallel::mclapply(seq_along(unique(df$INNER_ID_EMD)), function(j_n) {
214	800x	i <- unique(df$INNER_ID_EMD)[i_n]
215	800x	j <- unique(df$INNER_ID_EMD)[j_n]
216	800x	if (i_n < j_n) {
217	380x	dist_1d(
218	380x	as.numeric(df[df$INNER_ID_EMD == as.character(i), value]),
219	380x	as.numeric(df[df$INNER_ID_EMD == as.character(j), value])
220		)
221		}
222	40x	}, mc.cores = parallel)
223		}))
224	2x	mat_obj[lower.tri(mat_obj)] <- values
225	2x	tmat_obj <- t(mat_obj)
226	2x	mat_obj[upper.tri(mat_obj)] <- tmat_obj[upper.tri(tmat_obj)]
227	2x	rownames(mat_obj) <- colnames(mat_obj) <- unique(df$INNER_ID_EMD)
228	2x	out_data <- mat_obj
229		} else { # make long data
230	2x	out_data <- do.call(rbind, lapply(seq_along(unique(df$INNER_ID_EMD)), function(i_n) {
231	100x	do.call(rbind, parallel::mclapply(seq_along(unique(df$INNER_ID_EMD)), function(j_n) {
232	5000x	i <- unique(df$INNER_ID_EMD)[i_n]
233	5000x	j <- unique(df$INNER_ID_EMD)[j_n]
234	5000x	emdOut <- NULL
235	5000x	if (i_n == j_n) {
236	100x	emdOut <- 0
237	4900x	} else if (i_n < j_n) {
238	2450x	emdOut <- dist_1d(
239	2450x	as.numeric(df[df$INNER_ID_EMD == as.character(i), value]),
240	2450x	as.numeric(df[df$INNER_ID_EMD == as.character(j), value])
241		)
242		}
243	5000x	if (!is.null(emdOut)) {
244	2550x	if (!is.null(include)) {
245	2550x	x <- rbind(
246	2550x	data.frame(
247	2550x	i = i, j = j, emd = emdOut,
248	2550x	df[df$INNER_ID_EMD == as.character(i), include][1, ],
249	2550x	df[df$INNER_ID_EMD == as.character(j), include][1, ]
250		),
251	2550x	data.frame(
252	2550x	i = j, j = i, emd = emdOut,
253	2550x	df[df$INNER_ID_EMD == as.character(j), include][1, ],
254	2550x	df[df$INNER_ID_EMD == as.character(i), include][1, ]
255		)
256		)
257	2550x	colnames(x) <- c("i", "j", method, paste0(include, "_i"), paste0(include, "_j"))
258		} else {
259	!	x <- data.frame(i = c(i, j), j = c(j, i), emd = emdOut)
260		}
261	2550x	x
262		}
263	100x	}, mc.cores = parallel))
264		}))
265		}
266	4x	return(out_data)
267		}
268
269		#* wide EMD calculation
270		#' @keywords internal
271		#' @noRd
272
273		.wideEmdCalculation <- function(df, cols, raiseError, parallel, id, include, mat, method) {
274	8x	dist_1d <- match.fun(paste0(method, "1d"))
275	8x	if (is.null(cols)) {
276	!	cols <- colnames(df)
277	8x	} else if (is.character(cols) && length(cols) == 1) {
278	8x	cols <- grepl(cols, colnames(df))
279		}
280		#* `raise error`
281	8x	.emdRaiseError(raiseError, df, parallel, trait = NULL)
282		#* `calculate emd`
283	8x	if (mat) { # make dist matrix
284	2x	mat_obj <- matrix(0, nrow = nrow(df), ncol = nrow(df))
285	2x	values <- unlist(lapply(seq_len(nrow(df)), function(i) {
286	40x	parallel::mclapply(seq_len(nrow(df)), function(j) {
287	800x	if (i < j) {
288	380x	dist_1d(as.numeric(df[i, cols]), as.numeric(df[j, cols]))
289		}
290	40x	}, mc.cores = parallel)
291		}))
292	2x	mat_obj[lower.tri(mat_obj)] <- values
293	2x	tmat_obj <- t(mat_obj)
294	2x	mat_obj[upper.tri(mat_obj)] <- tmat_obj[upper.tri(tmat_obj)]
295	2x	rownames(mat_obj) <- colnames(mat_obj) <- seq_len(nrow(df))
296	2x	out_data <- mat_obj
297	2x	if (!is.null(include)) {
298	!	rownames(out_data) <- interaction(df[, include])
299		}
300		} else { # make long dataframe
301	6x	out_data <- do.call(rbind, lapply(seq_len(nrow(df)), function(i) {
302	160x	do.call(rbind, parallel::mclapply(seq_len(nrow(df)), function(j) {
303	6000x	emdOut <- NULL
304	6000x	if (i == j) {
305	160x	emdOut <- 0
306	5840x	} else if (i < j) {
307	2920x	emdOut <- dist_1d(as.numeric(df[i, cols]), as.numeric(df[j, cols]))
308		}
309	6000x	if (!is.null(emdOut)) {
310	3080x	if (!is.null(include)) {
311	3080x	x <- rbind(
312	3080x	data.frame(i = i, j = j, emd = emdOut, df[i, include], df[j, include]),
313	3080x	data.frame(i = j, j = i, emd = emdOut, df[j, include], df[i, include])
314		)
315	3080x	colnames(x) <- c("i", "j", method, paste0(include, "_i"), paste0(include, "_j"))
316		} else {
317	!	x <- data.frame(i = c(i, j), j = c(j, i), emd = emdOut)
318		}
319	3080x	x
320		}
321	160x	}, mc.cores = parallel))
322		}))
323		}
324	8x	return(out_data)
325		}
326
327		#' Earth Mover's Distance between spectral histograms
328		#'
329		#' @description emd1d computes 1 dimension EMD for two samples.
330		#'
331		#' @param s1 Histogram as a numeric vector of counts per position.
332		#' @param s2 Histogram as a numeric vector of counts per position. Must be the same length as s1.
333		#'
334		#' @keywords internal
335		#' @return Returns EMD between two samples as a numeric.
336		#' @examples
337		#'
338		#' set.seed(123)
339		#' s1 <- hist(rnorm(10000, 50, 10), breaks = seq(1, 100, 1))$counts
340		#' s2 <- hist(rlnorm(9000, log(30), 0.25), breaks = seq(1, 100, 1))$counts
341		#' plot(s2, type = "l"); lines(s1)
342		#' emd1d(s1, s2)
343		#'
344		#' @noRd
345		#'
346		emd1d <- function(s1, s2) {
347	5561x	if (length(s1) != length(s2)) {
348	1x	stop("Samples must be from the same histogram and be of the same length")
349		}
350	5560x	s1 <- s1 / sum(s1)
351	5560x	s2 <- s2 / sum(s2)
352	5560x	emd_iter <- numeric(length(s1) + 1)
353	5560x	for (i in seq_along(s1)) {
354	1169330x	emd_iter[i + 1] <- s1[i] - s2[i] + emd_iter[i]
355		}
356	5560x	return(sum(abs(emd_iter)))
357		}
358
359		#' Euclidean Distance between spectral histograms
360		#'
361		#' @description euc1d computes euclidean distance between two samples.
362		#'
363		#' @param s1 Histogram as a numeric vector of counts per position.
364		#' @param s2 Histogram as a numeric vector of counts per position. Must be the same length as s1.
365		#'
366		#' @importFrom stats dist
367		#' @keywords internal
368		#' @return Returns euclidean distance as a numeric
369		#'
370		#' @noRd
371
372		euc1d <- function(s1, s2) {
373	571x	if (length(s1) != length(s2)) {
374	1x	stop("Samples must be from the same histogram and be of the same length")
375		}
376	570x	s1 <- s1 / sum(s1)
377	570x	s2 <- s2 / sum(s2)
378	570x	mat <- matrix(c(s1, s2), nrow = 2, byrow = TRUE)
379	570x	euc <- as.numeric(stats::dist(mat, method = "euclidean"))
380	570x	return(euc)
381		}
382
383		#' @rdname pcv.emd
384		#' @export
385		#'
386		pcv.euc <- function(df, cols = NULL, reorder = NULL, include = reorder, mat = FALSE, plot = TRUE,
387		parallel = getOption("mc.cores", 1), trait = "trait", id = "image",
388		value = "value", raiseError = TRUE, method = "euc") {
389	2x	pcv.emd(df, cols, reorder, include, mat, plot, parallel, trait, id, value, raiseError, method)
390		}

1		#' @description
2		#' Internal function for calculating the gamma distributed scale parameter of a pareto distribution
3		#' represented by multi value traits.
4		#' @param s1 A data.frame or matrix of multi value traits.
5		#' @examples
6		#' library(extraDistr)
7		#' s1 <- mvSim(
8		#' dists = list(rpareto = list(a = 1, b = 1)),
9		#' n_samples = 10,
10		#' counts = 50,
11		#' min_bin = 1,
12		#' max_bin = 180,
13		#' wide = TRUE
14		#' )[, -1]
15		#' out <- .conj_pareto_mv(s1, cred.int.level = 0.95)
16		#' lapply(out, head)
17		#'
18		#' @keywords internal
19		#' @noRd
20		.conj_pareto_mv <- function(s1 = NULL, priors = NULL,
21		plot = FALSE, support = NULL, cred.int.level = NULL,
22		calculatingSupport = FALSE) {
23	4x	out <- list()
24		#* `N observations`
25	4x	n_obs <- nrow(s1)
26		#* `Reorder columns if they are not in the numeric order`
27	4x	histColsBin <- as.numeric(sub("[a-zA-Z_.]+", "", colnames(s1)))
28	4x	bins_order <- sort(histColsBin, index.return = TRUE)$ix
29	4x	s1 <- s1[, bins_order]
30		#* `Min non-zero bin`
31	4x	obs_min <- min(unlist(lapply(seq_len(n_obs), function(i) {
32	120x	col <- colnames(s1)[which(s1[i, ] > 0)][1]
33	120x	as.numeric(gsub("[a-zA-Z]_*", "", col))
34	4x	})), na.rm = TRUE)
35		#* `make default prior if none provided`
36	4x	if (is.null(priors)) {
37	4x	priors <- list(a = 0.5, b = 0.5, known_location = obs_min)
38		}
39		#* `Note, the product of the data is not an obvious quantity with MV trait data.`
40		#* I talk about this some in my notes on 5/30/2024 but I think it might be a good chance
41		#* to try the alternative mv trait method that I'd been considering.
42		#* `Calculate Sufficient Statistics`
43		#* This is abnormal because one of the sufficient statistics is the product of the data.
44		#* That quantity does not translate well to the MV trait setting.
45		#* `MLE Estimates of Pareto Parameters`
46		#* Note this is being done per row of the MV data
47	4x	row_scales <- unlist(lapply(seq_len(n_obs), function(i) {
48	120x	d <- s1[i, ]
49		#* `Turn s1 matrix into a vector`
50	120x	X1 <- rep(histColsBin[bins_order], as.numeric(round(colSums(d))))
51		#* `Estimate parameters of pareto distribution of this row`
52	120x	scale_mle <- sum(d) / sum(log(X1))
53	120x	return(scale_mle)
54		}))
55	4x	scale_estimate <- mean(row_scales)
56	4x	sv_draws <- extraDistr::rpareto(n_obs, scale_estimate, priors$known_location)
57		#* `Update gamma prior with sufficient statistics`
58	4x	n <- length(sv_draws)
59	4x	m <- prod(sv_draws)
60	4x	a_prime <- priors$a + n
61	4x	b_prime <- 1 / (1 / priors$b + log(m) - n * log(priors$known_location))
62		#* `Define support if it is missing`
63	4x	if (is.null(support) && calculatingSupport) {
64	2x	quantiles <- qgamma(c(0.0001, 0.9999), a_prime, b_prime)
65	2x	return(quantiles)
66		}
67		#* `Make Posterior Draws`
68	2x	out$posteriorDraws <- rgamma(10000, a_prime, b_prime)
69		#* `posterior`
70	2x	dens1 <- dgamma(support, a_prime, b_prime)
71	2x	pdf1 <- dens1 / sum(dens1)
72	2x	out$pdf <- pdf1
73	2x	hde1 <- .gammaHDE(shape = a_prime, scale = 1 / b_prime)
74	2x	hdi1 <- qgamma(
75	2x	c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
76	2x	a_prime, b_prime
77		)
78		#* `Store summary`
79	2x	out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
80	2x	out$posterior <- list(
81	2x	"a" = a_prime,
82	2x	"b" = b_prime,
83	2x	"known_location" = priors$known_location
84		)
85		#* `save s1 data for plotting`
86	2x	if (plot) {
87	2x	out$plot_df <- data.frame(
88	2x	"range" = support,
89	2x	"prob" = pdf1,
90	2x	"sample" = rep("Sample 1", length(support))
91		)
92		}
93	2x	return(out)
94		}
95
96		#' @description
97		#' Internal function for calculating the gamma distributed scale parameter of a pareto distribution
98		#' represented by single value traits.
99		#' @param s1 A vector of numerics drawn from a pareto distribution.
100		#' @examples
101		#' out <- .conj_pareto_sv(
102		#' s1 = runif(10, 1, 1), cred.int.level = 0.95,
103		#' plot = FALSE
104		#' )
105		#' lapply(out, head)
106		#' @keywords internal
107		#' @noRd
108		.conj_pareto_sv <- function(s1 = NULL, priors = NULL,
109		plot = FALSE, support = NULL, cred.int.level = NULL,
110		calculatingSupport = FALSE) {
111	4x	out <- list()
112		#* `make default prior if none provided`
113	4x	if (is.null(priors)) {
114	4x	priors <- list(a = 0.5, b = 0.5, known_location = floor(min(s1)))
115		}
116		#* `Update gamma prior with sufficient statistics`
117	4x	n <- length(s1)
118	4x	m <- prod(s1)
119	4x	a_prime <- priors$a + n
120	4x	b_prime <- 1 / (1 / priors$b + log(m) - n * log(priors$known_location))
121		#* `Define support if it is missing`
122	4x	if (is.null(support) && calculatingSupport) {
123	2x	quantiles <- qgamma(c(0.0001, 0.9999), a_prime, b_prime)
124	2x	return(quantiles)
125		}
126		#* `Make Posterior Draws`
127	2x	out$posteriorDraws <- rgamma(10000, a_prime, b_prime)
128		#* `posterior`
129	2x	dens1 <- dgamma(support, a_prime, b_prime)
130	2x	pdf1 <- dens1 / sum(dens1)
131	2x	out$pdf <- pdf1
132	2x	hde1 <- .gammaHDE(shape = a_prime, scale = 1 / b_prime)
133	2x	hdi1 <- qgamma(
134	2x	c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))),
135	2x	a_prime, b_prime
136		)
137		#* `Store summary`
138	2x	out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
139	2x	out$posterior <- list(
140	2x	"a" = a_prime,
141	2x	"b" = b_prime,
142	2x	"known_location" = priors$known_location
143		)
144		#* `save s1 data for plotting`
145	2x	if (plot) {
146	2x	out$plot_df <- data.frame(
147	2x	"range" = support,
148	2x	"prob" = pdf1,
149	2x	"sample" = rep("Sample 1", length(support))
150		)
151		}
152	2x	return(out)
153		}

1		#' Ease of use brms starter function for 6 growth model parameterizations
2		#'
3		#' @param model The name of a model as a character string.
4		#' Supported options are "logistic", "gompertz", "frechet", "gumbel", "weibull",
5		#' "monomolecular", "exponential", "linear", "logarithmic",
6		#' "power law", "double logistic", "double gompertz", and "gam".
7		#' See \code{\link{growthSim}} for examples of each type of growth curve.
8		#' @param form A formula describing the model. The left hand side should only be
9		#' the outcome variable (phenotype). The right hand side needs at least the x variable
10		#' (typically time). Grouping is also described in this formula using roughly lme4
11		#' style syntax,with formulas like \code{y~time\|individual/group} to show that predictors
12		#' should vary by \code{group} and autocorrelation between \code{individual:group}
13		#' interactions should be modeled. If group has only one level or is not included then
14		#' it will be ignored in formulas for growth and variance (this may be the case if
15		#' you split data before fitting models to be able to run more smaller models each more quickly).
16		#' @param sigma A model for heteroskedasticity from the same list of options as the model argument.
17		#' @param df A dataframe to use. Must contain all the variables listed in the formula.
18		#' @param priors A named list of means for prior distributions.
19		#' Currently this function makes lognormal priors for all growth model parameters
20		#' and T_5(mu, 3) priors for changepoint parameters.
21		#' This is done because the values are strictly positive and the lognormal distribution
22		#' is easily interpreted. The changepoint priors are T distributions for symmetry, 5 DF
23		#' having been chosen for heavy but not unmanageable tails.
24		#' If this argument is not provided then priors are not
25		#' returned and a different set of priors will need to be made for the model using
26		#' \code{brms::set_prior}. This works similarly to the \code{params} argument
27		#' in \code{growthSim}. Names should correspond to parameter names from the
28		#' \code{model} argument. A numeric vector can also be used, but specifying
29		#' names is best practice for clarity. Additionally, due to a limitation in
30		#' \code{brms} currently lower bounds cannot be set for priors for specific groups.
31		#' If priors include multiple groups (\code{priors = list(A = c(10,15), ...)}) then
32		#' you will see warnings after the model is fit about not having specified a lower
33		#' bound explicitly. Those warnings can safely be ignored and will be addressed if
34		#' the necessary features are added to \code{brms}. For GAMs priors are not created by
35		#' this function but can still be provided as a \code{brmsprior} object.
36		#' See details for guidance.
37		#' @param int Logical, should an intercept term be included?
38		#' @keywords Bayesian, brms
39		#'
40		#' @importFrom stats as.formula rgamma
41		#'
42		#' @details
43		#'
44		#' Default informative priors are not provided,
45		#' but these can serve as starting points for each distribution.
46		#' You are encouraged to use \code{growthSim} to consider what kind
47		#' of trendlines result from changes to your prior and for interpretation of each parameter.
48		#' You should not looking back and forth at your data trying to match your
49		#' observed growth exactly with a prior distribution,
50		#' rather this should be informed by an understanding of the plants you
51		#' are using and expectations based on previous research.
52		#' For the "double" models the parameter interpretation is the same
53		#' as for their non-double counterparts except that there are A and A2, etc.
54		#' It is strongly recommended to familiarize yourself with the double sigmoid
55		#' distributions using growthSim before attempting to model one. Additionally,
56		#' those distributions are intended for use with long delays in an experiment,
57		#' think stress recovery experiments, not for minor hiccups in plant growth.
58		#'
59		#' \itemize{
60		#' \item \bold{Logistic}: \code{list('A' = 130, 'B' = 12, 'C' = 3)}
61		#' \item \bold{Gompertz}: \code{list('A' = 130, 'B' = 12, 'C' = 1.25)}
62		#' \item \bold{Double Logistic}: \code{list('A' = 130, 'B' = 12, 'C' = 3,
63		#' 'A2' = 200, 'B2' = 25, 'C2' = 1)}
64		#' \item \bold{Double Gompertz}: \code{list('A' = 130, 'B' = 12, 'C' = 0.25,
65		#' 'A2' = 220, 'B2' = 30, 'C2' = 0.1)}
66		#' \item \bold{Monomolecular}: \code{list('A' = 130, 'B' = 2)}
67		#' \item \bold{Exponential}: \code{list('A' = 15, 'B' = 0.1)}
68		#' \item \bold{Linear}: \code{list('A' = 1)}
69		#' \item \bold{Power Law}: \code{list('A' = 13, 'B' = 2)}
70		#' }
71		#'
72		#'
73		#'
74		#' The \code{sigma} argument optionally specifies a sub model to account for heteroskedasticity.
75		#' Currently there are four supported sub models described below.
76		#'
77		#' \itemize{
78		#' \item \bold{homo}: \code{sigma ~ 1}, fitting only a global or per group intercept to sigma.
79		#' \item \bold{linear}: \code{sigma ~ time}, modeling sigma with a linear relationship to time
80		#' and possibly with an interaction term per groups.
81		#' \item \bold{spline}: \code{sigma ~ s(time)}, modeling sigma using a smoothing function through
82		#' `mgcv::s`, possibly by group.
83		#' \item \bold{gompertz}: \code{sigma ~ subA * exp(-subB * exp(-subC * x))},
84		#' modeling sigma as a gompertz function of time, possibly by group. Note that you
85		#' should specify priors for the parameters in this sub model by adding them into the \code{priors}
86		#' argument, such as \code{list(..., subA = 20, subB = 15, subC = 0.25)}. If you do not specify
87		#' priors then default (flat) priors will be used, which is liable to cause fitting problems
88		#' and less accurate results. Looking at your data and making a semi-informed estimate of the
89		#' total variance at the end of the experiment can help set a reasonable prior for subA, while
90		#' subB and subC can generally be the same as B and C in a gompertz growth model of the same data.
91		#' These priors will have fat tails so they are pretty forgiving.
92		#' }
93		#'
94		#'
95		#' @return A named list of elements to make it easier to fit common brms models.
96		#' \code{formula}: A \code{brms::bf} formula specifying the growth model, autocorrelation, variance
97		#' submodel, and models for each variable in the growth model.
98		#' \code{prior}: A brmsprior/data.frame object.
99		#' \code{initfun}: A function to randomly initialize chains using a random draw from a gamma
100		#' distribution (confines initial values to positive and makes correct number
101		#' of initial values for chains and groups). For "gam" models this initializes all chains at 0.
102		#' \code{df} The data input, possibly with dummy variables added if needed.
103		#' \code{family} The model family, currently this will always be "student".
104		#' \code{pcvrForm} The form argument unchanged. This is returned so that
105		#' it can be used later on in model visualization. Often it may be a good idea
106		#' to save the output of this function with the fit model, so having this can
107		#' be useful later on.
108		#' @examples
109		#'
110		#' simdf <- growthSim("logistic",
111		#' n = 20, t = 25,
112		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
113		#' )
114		#' ss <- .brmSS(
115		#' model = "logistic", form = y ~ time \| id / group,
116		#' sigma = "spline", df = simdf, priors = list("A" = 130, "B" = 12, "C" = 3)
117		#' )
118		#' lapply(ss, class)
119		#' ss$initfun()
120		#'
121		#' @keywords internal
122		#' @noRd
123
124		.brmSS <- function(model, form, sigma = NULL, df, priors = NULL, int = FALSE, hierarchy = NULL) {
125	39x	out <- list()
126	39x	models <- c(
127	39x	"int", "logistic", "gompertz", "monomolecular", "exponential", "linear", "power law", "logarithmic",
128	39x	"double logistic", "double gompertz", "gam", "spline", "homo", "frechet", "gumbel", "weibull",
129	39x	"not_estimated", "bragg", "lorentz", "beta"
130		)
131		#* *** `Make bayesian formula` ***
132		#* `parse form argument`
133	39x	parsed_form <- .parsePcvrForm(form, df)
134	39x	y <- parsed_form$y
135	39x	if (grepl("\\[", y)) {
136	1x	lims <- gsub(".*\\[\|\\]", "", y)
137	1x	lims <- as.numeric(strsplit(lims, ",")[[1]])
138	1x	lower <- lims[1]
139	1x	upper <- lims[2]
140	1x	y <- trimws(gsub("\\[.*", paste0("\|trunc(lb=", lower, ", ub=", upper, ")"), y))
141		}
142	39x	x <- parsed_form$x
143	39x	individual <- parsed_form$individual
144	39x	group <- parsed_form$group
145	39x	USEGROUP <- parsed_form$USEG
146	39x	USEINDIVIDUAL <- parsed_form$USEID
147	39x	df <- parsed_form$data
148	39x	hierarchical_predictor <- parsed_form$hierarchical_predictor
149
150		#* `convert group to character to avoid unexpected factor stuff`
151	39x	df[[group]] <- as.character(df[[group]])
152		#* `Make autocorrelation formula`
153	39x	if (USEINDIVIDUAL) {
154	36x	corForm <- as.formula(paste0("~arma(~", x, "\|", individual, ":", group, ",1,1)"))
155		} else {
156	3x	corForm <- NULL
157		}
158		#* `get family specific elements`
159	39x	family_res <- .brmFamilyHelper(model)
160	39x	model <- family_res$rhs
161	39x	family <- family_res$family
162	39x	dpars <- family_res$dpars
163		#* `Reformat sigma if it is a formula`
164	39x	sigma <- .sigmaHelper(sigma, dpars, family, models)
165		#* `match args`
166	39x	matchGrowthModelRes <- .matchGrowthModel(model, models)
167	39x	matched_model <- matchGrowthModelRes[["model"]]
168	39x	decay <- matchGrowthModelRes[["decay"]]
169		#* `Make growth formula`
170	39x	nTimes <- min(unlist(lapply(split(df, df[[group]]), function(d) {
171	97x	length(unique(d[[x]]))
172	39x	}))) # for spline knots
173	39x	splineHelperForm <- NULL
174	39x	if (grepl("\\+", model)) {
175	2x	chngptHelperList <- .brmsChangePointHelper(model, x, y, group,
176	2x	dpar = FALSE, nTimes = nTimes,
177	2x	useGroup = USEGROUP, priors = priors, int = int
178		)
179	2x	growthForm <- chngptHelperList$growthForm
180	2x	pars <- chngptHelperList$pars
181	2x	splineHelperForm <- chngptHelperList$splineHelperForm
182		} else {
183	37x	matched_model <- gsub("homo", "int", matched_model)
184	37x	matched_model <- gsub("spline", "gam", matched_model)
185
186	37x	stringBrmsFormFun <- paste0(".brms_form_", gsub(" ", "", matched_model))
187	37x	brmsFormFun <- match.fun(stringBrmsFormFun)
188	37x	formRes <- brmsFormFun(x, y, group,
189	37x	dpar = FALSE, nTimes = nTimes,
190	37x	useGroup = USEGROUP, prior = priors, int = int
191		)
192	37x	if (decay) {
193	1x	formRes <- .brms_form_decay(formRes, int)
194		}
195	37x	pars <- formRes$pars
196	37x	growthForm <- formRes$form
197		}
198
199		#* `Make distributional parameter formulas`
200		#* Note there is always a sigma after .sigmaHelper (it just might be homoskedastic)
201	39x	dpar_res <- lapply(seq_along(sigma), function(i) {
202	77x	dpar <- names(sigma)[[i]]
203	77x	model <- sigma[[i]]
204	77x	intModelRes <- .intModelHelper(model)
205	77x	model <- intModelRes$model
206	77x	sigmaInt <- intModelRes$int
207	77x	.brmDparHelper(dpar, model, x, group, nTimes, USEGROUP, priors, sigmaInt)
208		})
209	39x	names(dpar_res) <- names(sigma)
210	39x	dparForm <- unlist(lapply(dpar_res, function(res) {
211	77x	res$dparForm
212		}))
213	39x	dparSplineHelperForm <- unlist(lapply(dpar_res, function(res) {
214	77x	res$dparSplineHelperForm
215		}))
216	39x	dpar_pars <- unlist(lapply(dpar_res, function(res) {
217	77x	res$dpar_pars
218		}))
219	39x	names(dpar_pars) <- NULL
220	39x	pars <- append(pars, dpar_pars)
221	39x	pars <- pars[!grepl("spline", pars)]
222
223		#* `Make hierarchical parameter model formulas`
224	39x	if (!is.null(hierarchical_predictor)) {
225	1x	if (is.null(hierarchy)) {
226	1x	warning(paste0(
227	1x	"hierarchy argument not provided, assuming linear models with intercepts ",
228	1x	"for all ", matched_model, " model parameters (",
229	1x	paste(pars, collapse = ", "),
230		")."
231		))
232	1x	hierarchy <- lapply(pars, function(p) {
233	3x	"int_linear"
234		})
235	1x	names(hierarchy) <- pars
236		}
237
238	1x	hrc_res <- lapply(names(hierarchy), function(pname) {
239	3x	hrc_model <- hierarchy[[pname]]
240	3x	intModelRes <- .intModelHelper(hrc_model)
241	3x	hrc_model <- intModelRes$model
242	3x	hrc_int <- intModelRes$int
243	3x	.brmDparHelper(
244	3x	dpar = pname, model = hrc_model, x = hierarchical_predictor,
245	3x	group, nTimes, USEGROUP, priors, int = hrc_int
246		)
247		#* here passing `pname` to the `dpar` argument of .brmDparHelper will make
248		#* .brmDparHelper add that name as a prefix on all of the existing model parameters.
249		#* Since all the parameter names are unique coming into this they will be unique coming
250		#* out of this as well.
251		#* I'm also passing hierarchical_predictor to the x argument
252		})
253	1x	names(hrc_res) <- names(hierarchy)
254	1x	hrcForm <- unlist(lapply(hrc_res, function(res) {
255	3x	res$dparForm
256		}))
257	1x	hrcSplineHelperForm <- unlist(lapply(hrc_res, function(res) {
258	3x	res$dparSplineHelperForm
259		}))
260	1x	hrc_pars <- unlist(lapply(hrc_res, function(res) {
261	3x	res$dpar_pars
262		}))
263	1x	names(hrc_pars) <- NULL
264	1x	pars <- append(pars, hrc_pars)
265	1x	pars <- pars[-which(pars %in% names(hierarchy))] #* remove pars that are now estimated by other
266		#* sub models from the later steps.
267		} else {
268	38x	hrcForm <- NULL
269	38x	hrcSplineHelperForm <- NULL
270		}
271	39x	pars <- pars[!grepl("spline", pars)]
272
273		#* `Make parameter grouping formulae`
274
275	39x	if (!is.null(pars)) {
276	38x	if (USEGROUP) {
277	35x	parForm <- as.formula(paste0(paste(pars, collapse = "+"), "~0+", group))
278		} else {
279	3x	parForm <- as.formula(paste0(paste(pars, collapse = "+"), "~1"))
280		}
281		} else {
282	1x	parForm <- NULL
283		}
284
285		#* `Combine formulas into brms.formula object`
286	39x	if (is.null(parForm)) {
287	1x	NL <- FALSE
288		} else {
289	38x	NL <- TRUE
290		}
291	39x	bf_args <- list(
292	39x	"formula" = growthForm, dparForm, hrcForm, parForm,
293	39x	dparSplineHelperForm, hrcSplineHelperForm, splineHelperForm,
294	39x	"autocor" = corForm, "nl" = NL
295		)
296	39x	bf_args <- bf_args[!unlist(lapply(bf_args, is.null))]
297	39x	bayesForm <- do.call(brms::bf, args = bf_args)
298
299	39x	out[["formula"]] <- bayesForm
300		#* *** `Make priors` ***
301	39x	out[["prior"]] <- .makePriors(priors, pars, df, group, USEGROUP, sigma, family, bayesForm)
302		#* *** `Make initializer function` ***
303	38x	if (!is.null(pars)) {
304	37x	initFun <- function(pars = "?", nPerChain = 1) {
305	1x	init <- lapply(pars, function(i) array(rgamma(nPerChain, 1)))
306	1x	names(init) <- paste0("b_", pars)
307	1x	init
308		}
309	37x	formals(initFun)$pars <- pars
310	37x	formals(initFun)$nPerChain <- length(unique(df[[group]]))
311	37x	wrapper <- function() {
312	1x	initFun()
313		}
314		} else {
315	1x	wrapper <- 0
316		}
317
318		#* *** `Raise Message for complex models` ***
319
320	38x	if (length(pars) * length(unique(df[[group]])) > 50) {
321	1x	message(paste0(
322	1x	"This model will estimate >50 parameters (excluding any smooth terms). \n\n",
323	1x	"If the MCMC is very slow then consider fitting separate models and using `combineDraws()` ",
324	1x	"to make a data.frame for hypothesis testing."
325		))
326		}
327
328		#* *** `Return Components` ***
329	38x	out[["initfun"]] <- wrapper
330	38x	out[["df"]] <- df
331	38x	out[["family"]] <- family
332	38x	out[["pcvrForm"]] <- form
333	38x	return(out)
334		}

1		#' Function to visualize brms survival models specified using growthSS.
2		#'
3		#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
4		#' (and similar models made through other means)
5		#' can be visualized easily using this function. This will generally be called by \code{growthPlot}.
6		#'
7		#' @param fit A brmsfit object, similar to those fit with \code{\link{growthSS}} outputs.
8		#' @param form A formula similar to that in \code{growthSS} inputs specifying the outcome,
9		#' predictor, and grouping structure of the data as \code{outcome ~ predictor\|individual/group}.
10		#' @param df An optional dataframe to use in plotting observed growth curves on top of the model.
11		#' @param groups An optional set of groups to keep in the plot.
12		#' Defaults to NULL in which case all groups in the model are plotted.
13		#' @param timeRange An optional range of times to use. This can be used to view predictions for
14		#' future data if the available data has not reached some point (such as asymptotic size),
15		#' although prediction using splines outside of the observed range is not necessarily reliable.
16		#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
17		#' @import ggplot2
18		#' @import viridis
19		#' @importFrom stats as.formula
20		#' @examples
21		#' \donttest{
22		#' set.seed(123)
23		#' df <- growthSim("exponential",
24		#' n = 20, t = 50,
25		#' params = list("A" = c(1, 1), "B" = c(0.15, 0.1))
26		#' )
27		#' ss1 <- growthSS(
28		#' model = "survival weibull", form = y > 100 ~ time \| id / group,
29		#' df = df, start = c(0, 5)
30		#' )
31		#' fit1 <- fitGrowth(ss1, iter = 600, cores = 2, chains = 2, backend = "cmdstanr")
32		#' brmSurvPlot(fit1, form = ss1$pcvrForm, df = ss1$df)
33		#'
34		#' # note that using the cumulative hazard to calculate survival is likely to underestimate
35		#' # survival in these plots if events do not start immediately.
36		#' ss2 <- growthSS(
37		#' model = "survival binomial", form = y > 100 ~ time \| id / group,
38		#' df = df, start = c(-4, 3)
39		#' )
40		#' fit2 <- fitGrowth(ss2, iter = 600, cores = 2, chains = 2, backend = "cmdstanr")
41		#' brmSurvPlot(fit2, form = ss2$pcvrForm, df = ss2$df)
42		#' }
43		#'
44		#' @return Returns a ggplot showing a brms model's credible
45		#' intervals and optionally the individual growth lines.
46		#'
47		#' @export
48
49		brmSurvPlot <- function(fit, form, df = NULL, groups = NULL, timeRange = NULL, facetGroups = TRUE) {
50	!	family <- as.character(fit$family)[1]
51
52	!	if (family == "weibull") {
53	!	p <- .weibullBrmSurvPlot(
54	!	fit = fit, form = form, df = df, groups = groups,
55	!	timeRange = timeRange, facetGroups = facetGroups
56		)
57	!	} else if (family == "binomial") {
58	!	p <- .binomialBrmSurvPlot(
59	!	fit = fit, form = form, df = df, groups = groups,
60	!	timeRange = timeRange, facetGroups = facetGroups
61		)
62		}
63	!	return(p)
64		}
65
66		#' Internal Plotting function for weibull survival times
67		#' brms predicts mu where: scale = exp(mu) / (gamma(1 + 1 / shape))
68		#' @keywords internal
69		#' @noRd
70
71		.binomialBrmSurvPlot <- function(fit, form, df = NULL, groups = NULL,
72		timeRange = NULL, facetGroups = TRUE) {
73		#* `pull model data`
74	!	fitData <- fit$data
75		#* `general pcvr formula parsing`
76	!	parsed_form <- .parsePcvrForm(form, df)
77	!	x <- parsed_form$x
78	!	group <- parsed_form$group
79	!	df <- parsed_form$data
80		#* `set groups to use`
81	!	if (is.null(groups)) {
82	!	groups <- unique(fitData[[group]])
83		}
84		#* `pull draws and convert to survival`
85	!	draws <- as.matrix(fit)
86	!	s_hat <- brms::inv_logit_scaled(draws[, grepl("^b_", colnames(draws))])
87	!	colnames(s_hat) <- gsub("b_", "haz_", colnames(s_hat))
88	!	s_hat <- 1 - s_hat # take complement of hazard
89	!	s_hat <- as.data.frame(
90	!	do.call(rbind, lapply(groups, function(grp) {
91	!	s_hat_grp <- s_hat[, grepl(paste0(group, grp, "$"), colnames(s_hat))]
92	!	x <- do.call(cbind, lapply(seq_len(ncol(s_hat_grp)), function(j) {
93	!	do.call(rbind, lapply(seq_len(nrow(s_hat_grp)), function(i) {
94	!	cumprod(s_hat_grp[i, 1:j])[j]
95		}))
96		}))
97	!	colnames(x) <- gsub("haz_", "surv_", colnames(s_hat_grp))
98	!	colnames(x) <- gsub(paste0(":", group, grp), "", colnames(x))
99	!	x <- as.data.frame(x)
100	!	x[[group]] <- grp
101	!	x
102		}))
103		)
104
105		#* `define probabilities and take quantiles`
106	!	probs <- seq(from = 99, to = 1, by = -2) / 100
107	!	quantiles <- as.data.frame(
108	!	do.call(rbind, lapply(groups, function(grp) {
109	!	s_hat_grp <- s_hat[s_hat[[group]] == grp, ]
110	!	grp_quantile <- as.data.frame(do.call(rbind, lapply(1:(ncol(s_hat_grp) - 1), function(i) {
111	!	quantile(s_hat_grp[, i], probs)
112		})))
113	!	colnames(grp_quantile) <- paste0("Q", seq(99, 1, -2))
114	!	nms <- colnames(s_hat_grp)[grepl("surv_", colnames(s_hat_grp))]
115	!	grp_quantile[[x]] <- as.numeric(gsub(paste0("surv_", x), "", nms))
116	!	grp_quantile[[group]] <- grp
117	!	grp_quantile
118		}))
119		)
120	!	quantiles <- quantiles[quantiles[[group]] %in% groups, ]
121		#* `Decide faceting`
122	!	facetLayer <- NULL
123	!	if (facetGroups && length(unique(fitData[[group]])) > 1) {
124	!	facetLayer <- ggplot2::facet_wrap(as.formula(paste0("~", group)))
125		}
126		#* `lengthen quantiles`
127	!	max_prime <- 0.99
128	!	min_prime <- 0.01
129	!	max_obs <- 49
130	!	min_obs <- 1
131	!	c1 <- (max_prime - min_prime) / (max_obs - min_obs)
132
133	!	longPreds <- do.call(rbind, lapply(seq_len(nrow(quantiles)), function(r) {
134	!	sub <- quantiles[r, ]
135	!	do.call(rbind, lapply(seq(1, 49, 2), function(i) {
136	!	min <- paste0("Q", i)
137	!	max <- paste0("Q", 100 - i)
138	!	iter <- sub[, c(x, group)]
139	!	iter$q <- round(1 - (c1 * (i - max_obs) + max_prime), 2)
140	!	iter$min <- sub[[min]]
141	!	iter$max <- sub[[max]]
142	!	iter
143		}))
144		}))
145
146		#* `Initialize Plot`
147	!	p <- ggplot2::ggplot(longPreds, ggplot2::aes(x = .data[[x]])) +
148	!	facetLayer +
149	!	ggplot2::labs(x = x, y = "Survival") +
150	!	ggplot2::scale_y_continuous(labels = scales::label_percent()) +
151	!	pcv_theme()
152		#* `Add Ribbons`
153	!	p <- p +
154	!	lapply(unique(longPreds$q), function(q) {
155	!	ggplot2::geom_ribbon(
156	!	data = longPreds[longPreds$q == q, ],
157	!	ggplot2::aes(
158	!	ymin = min,
159	!	ymax = max,
160	!	group = .data[[group]],
161	!	fill = q
162	!	), alpha = 0.5
163		)
164		}) +
165	!	viridis::scale_fill_viridis(direction = -1, option = "plasma") +
166	!	ggplot2::labs(fill = "Credible\nInterval")
167
168		#* `Add KM Trend`
169	!	if (!is.null(df)) {
170	!	df$pct_surv <- (1 - df$pct_event)
171	!	df[[x]] <- as.numeric(df[[x]])
172	!	p <- p + ggplot2::geom_line(data = df, ggplot2::aes(
173	!	x = .data[[x]],
174	!	y = .data[["pct_surv"]],
175	!	group = .data[[group]],
176	!	linetype = .data[[group]]
177	!	), color = "black", show.legend = FALSE)
178		}
179	!	return(p)
180		}
181
182
183		#' Internal Plotting function for weibull survival times
184		#' brms predicts mu where: scale = exp(mu) / (gamma(1 + 1 / shape))
185		#' @keywords internal
186		#' @noRd
187
188		.weibullBrmSurvPlot <- function(fit, form, df = NULL, groups = NULL,
189		timeRange = NULL, facetGroups = TRUE) {
190		#* `Transform draws`
191	!	fitData <- fit$data
192	!	fdf <- as.data.frame(fit)
193	!	mu_cols <- colnames(fdf)[grepl("b_", colnames(fdf))]
194	!	scales <- do.call(cbind, lapply(mu_cols, function(col) {
195	!	exp(fdf[[col]]) / (gamma(1 + (1 / fdf$shape)))
196		}))
197	!	colnames(scales) <- paste0("scale_", mu_cols)
198	!	fdf <- cbind(fdf, scales)
199		#* `general pcvr formula parsing`
200	!	parsed_form <- .parsePcvrForm(form, df)
201	!	x <- parsed_form$x
202	!	group <- parsed_form$group
203	!	df <- parsed_form$data
204		#* `further survival formula steps`
205
206		#* `Define Time Range`
207	!	if (is.null(timeRange)) {
208	!	timeRange <- seq(0, round(max(fitData[[x]]), -1), length.out = 100)
209		}
210		#* `set groups to use`
211	!	if (is.null(groups)) {
212	!	groups <- unique(fitData[[group]])
213		}
214		#* `Make Survival Quantiles`
215	!	probs <- seq(from = 99, to = 1, by = -2) / 100
216	!	quantiles <- do.call(rbind, lapply(groups, function(grp) {
217	!	test <- fdf[, c(paste0("scale_b_", group, grp), "shape")]
218	!	colnames(test) <- c("scale", "shape")
219	!	metrics <- do.call(rbind, lapply(probs, function(i) {
220	!	shape <- quantile(test[, "shape"], probs = i)
221	!	scale <- quantile(test[, "scale"], probs = i)
222	!	do.call(rbind, lapply(timeRange, function(t) {
223	!	t_row <- data.frame(
224	!	probs = i,
225	!	h = shape / scale * (t / scale)^(shape - 1),
226	!	cdf = 1 - exp(1)^-(t / scale)^shape,
227	!	pdf = shape / scale * (t / scale)^(shape - 1) * exp(1)^-(t / scale)^shape
228		)
229	!	t_row[[x]] <- t
230	!	t_row$St <- 1 - t_row$cdf
231	!	t_row$c <- -log(t_row$St)
232	!	t_row
233		}))
234		}))
235
236	!	metrics$probs2 <- round(metrics$probs * 100, 2)
237	!	metrics <- data.table::as.data.table(metrics)
238	!	wide_metrics <- as.data.frame(data.table::dcast(metrics, time ~ paste0("Q", probs2),
239	!	value.var = "St", fun.aggregate = mean
240		))
241	!	wide_metrics[[group]] <- grp
242	!	wide_metrics
243		}))
244		#* `Decide faceting`
245	!	facetLayer <- NULL
246	!	if (facetGroups && length(unique(fitData[[group]])) > 1) {
247	!	facetLayer <- ggplot2::facet_wrap(as.formula(paste0("~", group)))
248		}
249		#* `lengthen quantiles`
250	!	max_prime <- 0.99
251	!	min_prime <- 0.01
252	!	max_obs <- 49
253	!	min_obs <- 1
254	!	c1 <- (max_prime - min_prime) / (max_obs - min_obs)
255
256	!	longPreds <- do.call(rbind, lapply(seq_len(nrow(quantiles)), function(r) {
257	!	sub <- quantiles[r, ]
258	!	do.call(rbind, lapply(seq(1, 49, 2), function(i) {
259	!	min <- paste0("Q", i)
260	!	max <- paste0("Q", 100 - i)
261	!	iter <- sub[, c("time", group)]
262	!	iter$q <- round(1 - (c1 * (i - max_obs) + max_prime), 2)
263	!	iter$min <- sub[[min]]
264	!	iter$max <- sub[[max]]
265	!	iter
266		}))
267		}))
268		#* `Initialize Plot`
269	!	p <- ggplot2::ggplot(longPreds, ggplot2::aes(x = .data[["time"]])) +
270	!	facetLayer +
271	!	ggplot2::labs(x = x, y = "Survival") +
272	!	ggplot2::scale_y_continuous(labels = scales::label_percent()) +
273	!	pcv_theme()
274		#* `Add Ribbons`
275	!	p <- p +
276	!	lapply(unique(longPreds$q), function(q) {
277	!	ggplot2::geom_ribbon(
278	!	data = longPreds[longPreds$q == q, ],
279	!	ggplot2::aes(
280	!	ymin = min,
281	!	ymax = max,
282	!	group = .data[[group]],
283	!	fill = q
284	!	), alpha = 0.5
285		)
286		}) +
287	!	viridis::scale_fill_viridis(direction = -1, option = "plasma") +
288	!	ggplot2::labs(fill = "Credible\nInterval")
289		#* `Add KM Trend`
290	!	if (!is.null(df)) {
291	!	km_df <- do.call(rbind, lapply(groups, function(grp) {
292	!	sub <- df[df[[group]] == grp, ]
293	!	do.call(rbind, lapply(timeRange, function(ti) {
294	!	sum_events <- sum(c(sub[as.numeric(sub[[x]]) <= ti, "event"], 0))
295	!	n_at_risk <- nrow(sub) - sum_events
296	!	surv_pct <- n_at_risk / nrow(sub)
297	!	data.frame(
298	!	group = grp, time = ti, events = sum_events,
299	!	at_risk = n_at_risk, surv_pct = surv_pct
300		)
301		}))
302		}))
303	!	p <- p + ggplot2::geom_line(data = km_df, ggplot2::aes(
304	!	x = .data[["time"]],
305	!	y = .data[["surv_pct"]],
306	!	group = .data[["group"]],
307	!	linetype = .data[["group"]]
308	!	), color = "black", show.legend = FALSE)
309		}
310	!	return(p)
311		}

1		#' @description
2		#' Internal function for testing conjugate methods for MV and SV traits, useful for testing only.
3		#' @param method a conjugate method with mv and sv options
4		#' @param prior A prior for that conjugate method
5		#' @param generating a list similar to those for mvSim that will generate data. See example.
6		#' @examples
7		#' method = "vonmises"
8		#' prior = list(mu = 0, kappa = 1, known_kappa = 1, boundary = c(0, 180), n = 1)
9		#' generating = list(
10		#' s1 = list(f = "rnorm", n = 20, mean = 20, sd = 5),
11		#' s2 = list(f = "rnorm", n = 20, mean = 170, sd = 5)
12		#' )
13		#' .conjugate.mv.sv.testing(method, prior, generating)
14		#'
15		#' @keywords internal
16		#' @noRd
17
18		.conjugate.mv.sv.testing <- function(method, prior, generating) {
19	6x	s1 <- do.call(generating[[1]][[1]], generating[[1]][-1])
20	6x	s2 <- do.call(generating[[2]][[1]], generating[[2]][-1])
21
22	6x	dists1 <- stats::setNames(list(generating[[1]][-1]), generating[[1]][[1]])
23	6x	m1 <- mvSim(dists1, n_samples = generating[[1]]$n)[, -1]
24	6x	dists2 <- stats::setNames(list(generating[[2]][-1]), generating[[2]][[1]])
25	6x	m2 <- mvSim(dists2, n_samples = generating[[2]]$n)[, -1]
26
27	6x	ps <- conjugate(s1, s2, method = method, priors = prior, plot = FALSE, cred.int.level = 0.95)
28	6x	pm <- conjugate(m1, m2, method = method, priors = prior, plot = FALSE, cred.int.level = 0.95)
29	6x	ps$posterior[[1]]$datatype <- "sv"
30	6x	ps$posterior[[2]]$datatype <- "sv"
31	6x	pm$posterior[[1]]$datatype <- "mv"
32	6x	pm$posterior[[2]]$datatype <- "mv"
33	6x	ps$summary$datatype <- "sv"
34	6x	pm$summary$datatype <- "mv"
35	6x	posteriors <- do.call(rbind, c(ps$posterior, pm$posterior))
36	6x	summaries <- rbind(ps$summary, pm$summary)
37	6x	data_used <- list(sv_s1 = s1, sv_s2 = s2, mv_s1 = m1, mv_s2 = m2)
38	6x	return(list("posteriors" = posteriors, "summaries" = summaries, "data_used" = data_used))
39		}

1		#' Function to visualize \code{flexsurv::flexsurvreg} models fit by \code{fitGrowth}.
2		#'
3		#' Models fit using \link{growthSS} inputs by \link{fitGrowth}
4		#' (and similar models made through other means) can be visualized easily using this function.
5		#' This will generally be called by \code{growthPlot}.
6		#'
7		#' @param fit A model fit returned by \code{fitGrowth} with type="nls".
8		#' @param form A formula similar to that in \code{growthSS} inputs
9		#' (or the \code{pcvrForm} part of the output) specifying the outcome,
10		#' predictor, and grouping structure of the data as \code{outcome ~ predictor\|individual/group}.
11		#' If the individual and group are specified then the observed growth lines are plotted.
12		#' @param groups An optional set of groups to keep in the plot.
13		#' Defaults to NULL in which case all groups in the model are plotted.
14		#' @param df A dataframe to use in plotting observed growth curves on top of the model.
15		#' This must be supplied for nls models.
16		#' @param timeRange Ignored, included for compatibility with other plotting functions.
17		#' @param facetGroups logical, should groups be separated in facets? Defaults to TRUE.
18		#' @param groupFill logical, should groups have different colors? Defaults to FALSE. If TRUE then
19		#' viridis colormaps are used in the order of virMaps
20		#' @param virMaps order of viridis maps to use. Will be recycled to necessary length.
21		#' Defaults to "plasma", but will generally be informed by growthPlot's default.
22		#' @keywords survival
23		#' @importFrom methods is
24		#' @import ggplot2
25		#' @importFrom stats predict
26		#' @examples
27		#'
28		#' df <- growthSim("logistic",
29		#' n = 20, t = 25,
30		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
31		#' )
32		#' ss <- growthSS(
33		#' model = "survival weibull", form = y > 100 ~ time \| id / group,
34		#' df = df, type = "flexsurv"
35		#' )
36		#' fit <- fitGrowth(ss)
37		#' flexsurvregPlot(fit, form = ss$pcvrForm, df = ss$df, groups = "a")
38		#' flexsurvregPlot(fit,
39		#' form = ss$pcvrForm, df = ss$df,
40		#' facetGroups = FALSE, groupFill = TRUE
41		#' )
42		#'
43		#' @return Returns a ggplot showing an survival model's survival function.
44		#'
45		#' @export
46
47
48		flexsurvregPlot <- function(fit, form, groups = NULL, df = NULL, timeRange = NULL, facetGroups = TRUE,
49		groupFill = FALSE, virMaps = c("plasma")) {
50		#* `parse formula`
51	2x	parsed_form <- .parsePcvrForm(form, df)
52	2x	x <- parsed_form$x
53	2x	group <- parsed_form$group
54	2x	df <- parsed_form$data
55		#* `filter by groups if groups != NULL`
56	2x	if (!is.null(groups)) {
57	1x	df <- df[df[[group]] %in% groups, ]
58		} else {
59	1x	groups <- unique(df[[group]])
60		}
61		#* `generate predictions`
62	2x	pct <- seq(0.01, 0.99, 0.01)
63	2x	preds <- predict(fit,
64	2x	newdata = data.frame("group" = groups),
65	2x	type = "quantile", p = pct, se.fit = TRUE
66		)
67	2x	preds <- do.call(rbind, lapply(seq_along(preds[[1]]), function(i) {
68	3x	iter <- as.data.frame(preds[[1]][[i]])
69	3x	colnames(iter) <- c("pct", "est", "se")
70	3x	iter[[group]] <- groups[i]
71	3x	iter
72		}))
73	2x	preds$surv <- 1 - preds$pct
74		#* `facetGroups`
75	2x	if (facetGroups) {
76	1x	facet_layer <- ggplot2::facet_wrap(stats::as.formula(paste0("~", group)))
77		} else {
78	1x	facet_layer <- NULL
79		}
80		#* `groupFill`
81	2x	if (groupFill) {
82	1x	virVals <- lapply(rep(virMaps, length.out = length(unique(df[[group]]))), function(pal) {
83	2x	viridis::viridis(3, begin = 0.1, option = pal)
84		})
85	1x	names(virVals) <- groups
86	1x	color_scale <- ggplot2::scale_color_manual(values = unlist(lapply(virVals, function(pal) pal[3])))
87		} else {
88	1x	virVals <- lapply(rep("plasma", length.out = length(unique(df[[group]]))), function(pal) {
89	1x	viridis::viridis(3, begin = 0.1, option = pal)
90		})
91	1x	names(virVals) <- groups
92	1x	color_scale <- ggplot2::scale_color_manual(values = unlist(lapply(virVals, function(pal) pal[3])))
93		}
94		#* `Make ggplot`
95	2x	p <- ggplot2::ggplot(preds, ggplot2::aes(
96	2x	x = .data[["est"]],
97	2x	y = .data[["surv"]], group = .data[[group]]
98		)) +
99	2x	facet_layer +
100	2x	lapply(groups, function(grp) {
101	3x	ggplot2::geom_ribbon(data = preds[preds[[group]] == grp, ], ggplot2::aes(
102	3x	xmin = .data[["est"]] - (2 * .data[["se"]]),
103	3x	xmax = .data[["est"]] + (2 * .data[["se"]])
104	3x	), fill = virVals[[grp]][1], alpha = 0.5)
105		}) +
106	2x	lapply(groups, function(grp) {
107	3x	ggplot2::geom_ribbon(data = preds[preds[[group]] == grp, ], ggplot2::aes(
108	3x	xmin = .data[["est"]] - (1 * .data[["se"]]),
109	3x	xmax = .data[["est"]] + (1 * .data[["se"]])
110	3x	), fill = virVals[[grp]][2], alpha = 0.5)
111		}) +
112	2x	ggplot2::geom_line(ggplot2::aes(color = .data[[group]]), show.legend = FALSE) +
113	2x	color_scale +
114	2x	ggplot2::scale_y_continuous(labels = scales::label_percent()) +
115	2x	ggplot2::labs(x = x, y = "Survival") +
116	2x	pcv_theme()
117
118
119	2x	if (!is.null(df)) {
120	2x	km_df <- do.call(rbind, lapply(groups, function(grp) {
121	3x	sub <- df[df[[group]] == grp, ]
122	3x	do.call(rbind, lapply(seq(0, max(df[[x]]), 1), function(ti) {
123	54x	sum_events <- sum(c(sub[as.numeric(sub[[x]]) <= ti, "event"], 0))
124	54x	n_at_risk <- nrow(sub) - sum_events
125	54x	surv_pct <- n_at_risk / nrow(sub)
126	54x	iter <- data.frame(
127	54x	group = grp, time = ti, events = sum_events,
128	54x	at_risk = n_at_risk, surv_pct = surv_pct
129		)
130	54x	colnames(iter)[1] <- group
131	54x	iter
132		}))
133		}))
134	2x	p <- p + ggplot2::geom_line(data = km_df, ggplot2::aes(
135	2x	x = .data[[x]],
136	2x	y = .data[["surv_pct"]],
137	2x	group = .data[[group]],
138	2x	linetype = .data[[group]]
139	2x	), color = "black")
140		}
141
142	2x	return(p)
143		}

1		#' Function for plotting iterations of posterior distributions
2		#'
3		#' @param fits A list of brmsfit objects following the same data over time.
4		#' Currently checkpointing is not supported.
5		#' @param form A formula describing the growth model similar to \code{\link{growthSS}}
6		#' and \code{\link{brmPlot}} such as: outcome ~ predictor \|individual/group
7		#' @param df data used to fit models (this is used to plot each subject's trend line).
8		#' @param priors a named list of samples from the prior distributions for each parameter in
9		#' \code{params}. This is only used if sample_prior=FALSE in the brmsfit object.
10		#' If left NULL then no prior is included.
11		#' @param params a vector of parameters to include distribution plots of.
12		#' Defaults to NULL which will use all parameters from the top level model.
13		#' @param maxTime Optional parameter to designate a max time not observed in the models so far
14		#' @param patch Logical, should a patchwork plot be returned or should lists of ggplots be returned?
15		#' @keywords Bayesian brms
16		#' @import ggplot2
17		#' @import patchwork
18		#' @importFrom methods is
19		#' @importFrom stats setNames
20		#' @import viridis
21		#' @return A ggplot or a list of ggplots (depending on patch).
22		#' @export
23		#' @examples
24		#' \donttest{
25		#' print(load(url("https://raw.githubusercontent.com/joshqsumner/pcvrTestData/main/brmsFits.rdata")))
26		#' library(brms)
27		#' library(ggplot2)
28		#' library(patchwork)
29		#' fits <- list(fit_3, fit_15)
30		#' form <- y~time \| id / group
31		#' priors <- list(
32		#' "phi1" = rlnorm(2000, log(130), 0.25),
33		#' "phi2" = rlnorm(2000, log(12), 0.25),
34		#' "phi3" = rlnorm(2000, log(3), 0.25)
35		#' )
36		#' params <- c("A", "B", "C")
37		#' d <- simdf
38		#' maxTime <- NULL
39		#' patch <- TRUE
40		#' from3to25 <- list(
41		#' fit_3, fit_5, fit_7, fit_9, fit_11,
42		#' fit_13, fit_15, fit_17, fit_19, fit_21, fit_23, fit_25
43		#' )
44		#' distributionPlot(
45		#' fits = from3to25, form = y ~ time \| id / group,
46		#' params = params, d = d, priors = priors, patch = FALSE
47		#' )
48		#' distributionPlot(
49		#' fits = from3to25, form = y ~ time \| id / group,
50		#' params = params, d = d, patch = FALSE
51		#' )
52		#' }
53		#' ## End(Not run)
54		distributionPlot <- function(fits, form, df, priors = NULL,
55		params = NULL, maxTime = NULL, patch = TRUE) {
56		#* ***** `Reused helper variables`
57	!	parsed_form <- .parsePcvrForm(form, df)
58	!	y <- parsed_form$y
59	!	x <- parsed_form$x
60	!	individual <- parsed_form$individual
61	!	group <- parsed_form$group
62	!	d <- parsed_form$data
63	!	fitData <- fits[[length(fits)]]$data
64	!	dSplit <- split(d, d[[group]])
65	!	startTime <- min(unlist(lapply(fits, function(ft) {
66	!	min(ft$data[[x]], na.rm = TRUE)
67		})))
68	!	if (is.null(maxTime)) {
69	!	endTime <- max(unlist(lapply(fits, function(ft) {
70	!	max(ft$data[[x]], na.rm = TRUE)
71		})))
72		}
73	!	byTime <- mean(diff(unlist(lapply(fits, function(ft) {
74	!	max(ft$data[[x]], na.rm = TRUE)
75		}))))
76	!	timeRange <- seq(startTime, endTime, byTime)
77	!	virOptions <- c("C", "G", "B", "D", "A", "H", "E", "F")
78	!	palettes <- lapply(
79	!	seq_along(unique(fitData[[group]])),
80	!	function(i) {
81	!	viridis::viridis(length(timeRange),
82	!	begin = 0.1,
83	!	end = 1, option = virOptions[i], direction = 1
84		)
85		}
86		)
87	!	names(palettes) <- unique(fitData[[group]])
88
89		#* ***** `if params is null then pull them from growth formula`
90
91	!	if (is.null(params)) {
92	!	fit <- fits[[1]]
93	!	growthForm <- as.character(fit$formula[[1]])[[3]]
94
95	!	test <- gsub(x, "", growthForm) # ;test
96	!	test2 <- gsub("exp\\(", "", test) # ; test2
97	!	test3 <- gsub("\\(1", "", test2) # ;test3
98	!	test4 <- gsub("[/]\|[+]\|[-]\|[)]\|[()]", "", test3)
99	!	params <- strsplit(test4, "\\s+")[[1]]
100
101
102	!	test3 <- gsub("[)]\|[()]", "", test2)
103	!	test3
104		}
105
106		#* ***** `growth trendline plots`
107
108	!	growthTrendPlots <- lapply(seq_along(dSplit), function(i) {
109	!	dt <- dSplit[[i]]
110	!	ggplot2::ggplot(dt, ggplot2::aes(
111	!	x = .data[[x]], y = .data[[y]], color = .data[[x]],
112	!	group = .data[[individual]]
113		)) +
114	!	ggplot2::geom_line(show.legend = FALSE) +
115	!	viridis::scale_color_viridis(begin = 0.1, end = 1, option = virOptions[i], direction = 1) +
116	!	ggplot2::scale_x_continuous(limits = c(startTime, endTime)) +
117	!	pcv_theme()
118		})
119
120		#* ***** `posterior distribution extraction`
121
122	!	posts <- do.call(rbind, lapply(fits, function(fit) {
123	!	time <- max(fit$data[[x]], na.rm = TRUE)
124	!	fitDraws <- do.call(cbind, lapply(params, function(par) {
125	!	draws <- as.data.frame(fit)[grepl(par, colnames(as.data.frame(fit)))]
126	!	if (nrow(brms::prior_draws(fit)) > 1) {
127	!	draws <- draws[!grepl("^prior_", colnames(draws))]
128		}
129	!	splits <- strsplit(colnames(draws), split = "")
130	!	mx <- max(unlist(lapply(splits, length)))
131	!	ind <- which(unlist(lapply(1:mx, function(i) {
132	!	length(unique(rapply(splits, function(j) {
133	!	j[i]
134	!	}))) != 1
135		})))
136	!	if (length(ind) > 0) {
137	!	colnames(draws) <- paste(par, unlist(lapply(colnames(draws), function(c) {
138	!	substr(c, min(ind), max(c(ind, nchar(c))))
139	!	})), sep = "_")
140		}
141	!	draws
142		}))
143	!	fitDraws$time <- time
144	!	fitDraws
145		}))
146
147		#* ***** `prior distribution extraction`
148	!	distPlotPriorExtractionRes <- .distPlotPriorExtraction(fits, priors, d, group, params, x)
149	!	prior_df <- distPlotPriorExtractionRes[["prior_df"]]
150	!	USEPRIOR <- distPlotPriorExtractionRes[["UP"]]
151
152		#* ***** `posterior distribution plots`
153		#* need to assign ordering of factors
154		#* if USEPRIOR then join data, don't make separate geom
155
156	!	if (USEPRIOR) {
157	!	posts <- rbind(prior_df, posts)
158		}
159	!	posts[[x]] <- factor(posts[[x]], levels = sort(as.numeric(unique(posts[[x]]))), ordered = TRUE)
160
161	!	lapply(posts, summary)
162
163	!	xlims <- lapply(params, function(par) {
164	!	diff <- as.numeric(as.matrix(posts[, grepl(paste0("^", par, "_"), colnames(posts))]))
165	!	c(min(diff, na.rm = TRUE), max(diff, na.rm = TRUE))
166		})
167	!	names(xlims) <- params
168	!	postPlots <- lapply(unique(fitData[[group]]), function(groupVal) {
169	!	groupPlots <- lapply(params, function(par) {
170	!	p <- ggplot2::ggplot(posts) +
171	!	ggplot2::geom_density(ggplot2::aes(
172	!	x = .data[[paste(par, groupVal, sep = "_")]],
173	!	fill = .data[[x]], color = .data[[x]],
174	!	group = .data[[x]]
175	!	), alpha = 0.8) +
176	!	ggplot2::labs(x = paste(par, group, groupVal)) +
177	!	ggplot2::coord_cartesian(xlim = xlims[[par]]) +
178	!	pcv_theme() +
179	!	ggplot2::theme(
180	!	axis.text.x.bottom = ggplot2::element_text(angle = 0),
181	!	legend.position = "none", axis.title.y = ggplot2::element_blank()
182		)
183
184	!	if (USEPRIOR) {
185	!	p <- p + ggplot2::scale_fill_manual(values = c("black", palettes[[groupVal]])) +
186	!	ggplot2::scale_color_manual(values = c("black", palettes[[groupVal]]))
187		} else {
188	!	p <- p + ggplot2::scale_fill_manual(values = palettes[[groupVal]]) +
189	!	ggplot2::scale_color_manual(values = palettes[[groupVal]])
190		}
191	!	return(p)
192		})
193	!	return(groupPlots)
194		})
195
196	!	if (patch) {
197	!	ncol_patch <- 1 + length(params)
198	!	nrow_patch <- length(postPlots)
199
200	!	patchPlot <- growthTrendPlots[[1]] + postPlots[[1]]
201	!	if (length(unique(d[[group]])) > 1) {
202	!	for (i in 2:length(growthTrendPlots)) {
203	!	patchPlot <- patchPlot + growthTrendPlots[[i]] + postPlots[[i]]
204		}
205		}
206	!	out <- patchPlot + patchwork::plot_layout(ncol = ncol_patch, nrow = nrow_patch)
207		} else {
208	!	out <- list(growthTrendPlots, postPlots)
209		}
210	!	return(out)
211		}
212
213		#' Prior extraction in distPlot
214		#' @keywords internal
215		#' @noRd
216
217		.distPlotPriorExtraction <- function(fits, priors, d, group, params, x) {
218	!	if (is.null(priors)) {
219	!	return(list("prior_df" = NULL, "UP" = FALSE))
220		}
221	!	if (all(unlist(lapply(fits, function(fit) nrow(brms::prior_draws(fit)) < 1)))) {
222		# if no models were fit with sample_prior
223	!	if (!is.null(priors)) { # if prior is supplied as argument
224	!	USEPRIOR <- TRUE
225	!	if (!methods::is(priors[[1]], "list")) {
226	!	priors <- lapply(seq_along(unique(d[[group]])), function(i) priors)
227	!	names(priors) <- unique(d[[group]])
228		}
229	!	prior_df <- do.call(cbind, lapply(names(priors), function(nm) {
230	!	nmp <- priors[[nm]]
231	!	setNames(data.frame(do.call(cbind, lapply(names(nmp), function(nmpn) {
232	!	nmp[[nmpn]]
233	!	}))), paste0(names(nmp), "_", nm))
234		}))
235	!	prior_df[[x]] <- 0
236		} else {
237	!	USEPRIOR <- FALSE
238		}
239		} else { #* `need to fit some models with sample_prior and see how this works with them`
240	!	prior_df <- brms::prior_draws(fits[[1]])
241	!	prior_df <- prior_df[, grepl(paste0("b_", paste0(params, collapse = "\|")), colnames(prior_df))]
242	!	colnames(prior_df) <- gsub(group, "", colnames(prior_df))
243	!	colnames(prior_df) <- gsub("^b_", "", colnames(prior_df))
244	!	prior_df[[x]] <- 0
245	!	USEPRIOR <- TRUE
246		}
247	!	return(list("prior_df" = prior_df, "UP" = USEPRIOR))
248		}

1		#' Function to parse survival model specifications in growthSS for brms type models
2		#'
3		#' @param model a survival distribution to use (currently "binomial" and "weibull" are supported)
4		#' @param form a formula in pcvr syntax
5		#' @param df a dataframe to use
6		#' @param priors priors specified per details in growthSS
7		#'
8		#' @return A list of elements to pass to fitGrowth
9		#'
10		#' @examples
11		#' set.seed(123)
12		#' model = "survival weibull"
13		#' form <- y > 100 ~ time \| id / group
14		#' df <- growthSim("logistic",
15		#' n = 20, t = 25,
16		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
17		#' )
18		#' surv <- .survModelParser(model)
19		#' survivalBool <- surv$survival
20		#' model <- surv$model
21		#' prior <- c(0, 5)
22		#' ss <- .brmsSurvSS(model, form, df, prior)
23		#' lapply(ss, head)
24		#'
25		#' @keywords internal
26		#' @noRd
27
28		.brmsSurvSS <- function(model = NULL, form = NULL, df = NULL, priors = NULL) {
29	9x	out <- list()
30		#* `make survival data`
31	9x	fixData <- TRUE
32	9x	if (grepl("binomial", model)) {
33	4x	if (all(c("n_events", "n_eligible") %in% colnames(df))) {
34	2x	fixData <- FALSE
35		}
36		} else { # weibull
37	5x	if (all(c("event", "censor") %in% colnames(df))) {
38	2x	fixData <- FALSE
39		}
40		}
41	9x	if (fixData) {
42	5x	makeSurvDataRet <- .makeSurvData(df, form, model)
43	5x	out_df <- makeSurvDataRet$data
44	5x	out[["df"]] <- out_df
45		} else {
46	4x	makeSurvDataRet <- list()
47	4x	getGroup <- trimws(strsplit(as.character(form)[3], "[\|]\|[/]")[[1]])
48	4x	makeSurvDataRet$group <- getGroup[length(getGroup)]
49	4x	makeSurvDataRet$x <- getGroup[1]
50	4x	out_df <- df
51	4x	out[["df"]] <- out_df
52		}
53
54		#* `make bayesian formula`
55	9x	if (model == "binomial") {
56	4x	form_ret <- .brmsurv_binomial_formula(
57	4x	x = makeSurvDataRet$x, group = makeSurvDataRet$group,
58	4x	df = out_df
59		)
60	5x	} else if (model == "weibull") {
61	5x	form_ret <- .brmsurv_weibull_formula(
62	5x	x = makeSurvDataRet$x, group = makeSurvDataRet$group,
63	5x	df = out_df
64		)
65		}
66	9x	out[["family"]] <- form_ret$family
67	9x	out[["formula"]] <- form_ret$formula
68		#* `make priors if none specified`
69	9x	out[["prior"]] <- .brmsMakeSurvPriors(priors, out_df, makeSurvDataRet, form_ret)
70		#* `set initialization to 0 for all chains`
71	9x	out[["initfun"]] <- 0
72	9x	out[["pcvrForm"]] <- form
73	9x	return(out)
74		}
75
76
77		#' Helper function to make priors for brms survival models
78		#' @return A list with a formula and a model family
79		#' @keywords internal
80		#' @noRd
81
82		.brmsMakeSurvPriors <- function(priors, out_df, makeSurvDataRet, form_ret) {
83	9x	if (is.null(priors)) {
84	6x	return(brms::prior_string("normal(0, 5)", class = "b"))
85	3x	} else if (any(methods::is(priors, "brmsprior"))) {
86	1x	return(priors)
87	2x	} else if (is.numeric(priors)) {
88	2x	priors <- rep(priors, length.out = 2 * length(unique(out_df[[makeSurvDataRet$group]])))
89	2x	priors <- stats::setNames(
90	2x	lapply(seq(1, length(priors), 2), function(i) {
91	4x	c(priors[i], priors[i + 1])
92		}),
93	2x	unique(out_df[[makeSurvDataRet$group]])
94		)
95	2x	message(
96	2x	"Prior is numeric, replicating to ", length(unique(out_df[[makeSurvDataRet$group]])),
97	2x	" length 2 elements (mu, sd) and assuming order ",
98	2x	paste(unique(out_df[[makeSurvDataRet$group]]),
99	2x	collapse = ", "
100		)
101		)
102		}
103	2x	pars <- brms::get_prior(formula = form_ret$formula, data = out_df, family = form_ret$family)$coef
104	2x	pars <- pars[which(nchar(pars) > 0)]
105	2x	if (length(priors) != length(pars)) {
106	1x	message(paste0(
107	1x	"Priors and parameters are not the same length. Output will assume that priors are for groups",
108	1x	" and are in order: ", paste(unique(out_df[[makeSurvDataRet$group]]), collapse = ", ")
109		))
110	1x	priors <- stats::setNames(
111	1x	rep(priors, length.out = length(unique(out_df[[makeSurvDataRet$group]]))),
112	1x	unique(out_df[[makeSurvDataRet$group]])
113		)
114		}
115	2x	prior_obj <- NULL
116	2x	for (g in unique(out_df[[makeSurvDataRet$group]])) {
117	4x	sub_pars <- pars[grepl(paste0(makeSurvDataRet$group, g), pars)]
118	4x	for (param in sub_pars) {
119	52x	if (is.null(prior_obj)) {
120	2x	prior_obj <- brms::set_prior(
121	2x	prior = paste0("normal(", priors[[g]][1], ",", priors[[g]][2], ")"),
122	2x	coef = param
123		)
124		} else {
125	50x	prior_obj <- prior_obj + brms::set_prior(
126	50x	prior = paste0("normal(", priors[[g]][1], ",", priors[[g]][2], ")"),
127	50x	coef = param
128		)
129		}
130		}
131		}
132	2x	return(prior_obj)
133		}
134
135
136		#' Helper function to make formulas for brms binomial survival models
137		#' @return A list with a formula and a model family
138		#' @keywords internal
139		#' @noRd
140
141		.brmsurv_binomial_formula <- function(y = "n_events", x = "time", total = "n_eligible",
142		group = "groups", df = NULL) {
143		#* make formula
144	4x	if (is.null(group) \|\| length(unique(df[[group]])) == 1) {
145	1x	formula <- stats::as.formula(paste0(y, " \| trials(", total, ") ~ 0 + ", x))
146		} else {
147	3x	formula <- stats::as.formula(paste0(y, " \| trials(", total, ") ~ 0 + ", x, ":", group))
148		}
149		#* specify family
150	4x	family <- "binomial" # using default links
151	4x	return(list("formula" = formula, "family" = family))
152		}
153
154		#' Helper function to make formulas for brms weibull survival models
155		#' @return A list with a formula and a model family
156		#' @keywords internal
157		#' @noRd
158
159		.brmsurv_weibull_formula <- function(y = "event", x = "time", censor = "censor",
160		group = "groups", df = NULL) {
161		#* make formula
162	5x	if (is.null(group) \|\| length(unique(df[[group]])) == 1) {
163	1x	formula <- stats::as.formula(paste0(x, " \| cens(", censor, ") ~ 1"))
164		} else {
165	4x	formula <- stats::as.formula(paste0(x, " \| cens(", censor, ") ~ 0 + ", group))
166		}
167		#* specify family
168	5x	family <- "weibull" # using default links
169	5x	return(list("formula" = formula, "family" = family))
170		}
171
172
173
174
175		#' Function to parse survival model specifications in growthSS for modeling in the survival package
176		#'
177		#' @return a list of components passed to fitGrowth
178		#'
179		#' @examples
180		#'
181		#' set.seed(123)
182		#' model = "survival weibull"
183		#' form <- y > 100 ~ time \| id / group
184		#' df <- growthSim("logistic",
185		#' n = 20, t = 25,
186		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
187		#' )
188		#' surv <- .survModelParser(model)
189		#' survivalBool <- surv$survival
190		#' model <- surv$model
191		#' ss <- .survSS(model, form, df)
192		#' lapply(ss, head)
193		#'
194		#' @importFrom survival survreg Surv
195		#'
196		#' @keywords internal
197		#' @noRd
198
199		.survSS <- function(model = NULL, form = NULL, df = NULL) {
200	2x	out <- list()
201		#* `make survival data`
202	2x	fixData <- TRUE
203	2x	if (all(c("event") %in% colnames(df))) {
204	1x	fixData <- FALSE
205		}
206	2x	if (fixData) {
207	1x	makeSurvDataRet <- .makeSurvData(df, form, model = "weibull")
208	1x	out_df <- makeSurvDataRet$data
209	1x	out_df[[makeSurvDataRet$group]] <- factor(out_df[[makeSurvDataRet$group]])
210	1x	out_df[[paste0(makeSurvDataRet$group, "_numericLabel")]] <- unclass(out_df[[makeSurvDataRet$group]])
211	1x	out[["df"]] <- out_df
212		} else {
213	1x	makeSurvDataRet <- list()
214	1x	getGroup <- trimws(strsplit(as.character(form)[3], "[\|]\|[/]")[[1]])
215	1x	makeSurvDataRet$group <- getGroup[length(getGroup)]
216	1x	makeSurvDataRet$x <- getGroup[1]
217	1x	out[["df"]] <- df
218		}
219		#* `make survreg formula`
220	2x	x <- makeSurvDataRet$x
221	2x	group <- makeSurvDataRet$group
222	2x	if (is.null(group) \|\| length(unique(df[[group]])) == 1) {
223	1x	formula <- stats::as.formula(paste0("Surv(", x, ", event) ~ 1"))
224		} else {
225	1x	formula <- stats::as.formula(paste0("Surv(", x, ", event) ~ 1 + group"))
226		}
227	2x	out[["formula"]] <- formula
228		#* `return all`
229	2x	out[["pcvrForm"]] <- form
230	2x	out[["distribution"]] <- model
231	2x	return(out)
232		}
233
234
235		#' Function to parse survival model specifications in growthSS for modeling in the flexsurv package
236		#'
237		#' @return a list of components passed to fitGrowth
238		#'
239		#' @examples
240		#'
241		#' set.seed(123)
242		#' model = "survival gengamma"
243		#' form <- y > 100 ~ time \| id / group
244		#' df <- growthSim("logistic",
245		#' n = 20, t = 25,
246		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
247		#' )
248		#' surv <- .survModelParser(model)
249		#' survivalBool <- surv$survival
250		#' model <- surv$model
251		#' ss <- .flexSurvSS(model, form, df)
252		#' lapply(ss, head)
253		#'
254		#' @importFrom survival survreg Surv
255		#'
256		#' @keywords internal
257		#' @noRd
258
259		.flexSurvSS <- function(model = NULL, form = NULL, df = NULL, anc = NULL) {
260	4x	out <- list()
261	4x	distributions <- c(
262	4x	"gengamma", "gengamma.orig", "genf", "genf.orig",
263	4x	"weibull", "gamma", "exp", "llogis", "lnorm", "gompertz",
264	4x	"exponential", "lognormal"
265		)
266	4x	if (!model %in% distributions) {
267	1x	stop(paste0(
268	1x	"Supported distributions for flexsurv models are ",
269	1x	paste(distributions, collapse = ", "),
270	1x	".\nIf you are using a custom distribution please call flexsurvreg directly."
271		))
272		}
273		#* `make survival data`
274	3x	fixData <- TRUE
275	3x	if (all(c("event") %in% colnames(df))) {
276	1x	fixData <- FALSE
277		}
278	3x	if (fixData) {
279	2x	makeSurvDataRet <- .makeSurvData(df, form, model = "weibull")
280	2x	out_df <- makeSurvDataRet$data
281	2x	out_df[[makeSurvDataRet$group]] <- factor(out_df[[makeSurvDataRet$group]])
282	2x	out_df[[paste0(makeSurvDataRet$group, "_numericLabel")]] <- unclass(out_df[[makeSurvDataRet$group]])
283	2x	out[["df"]] <- out_df
284		} else {
285	1x	makeSurvDataRet <- list()
286	1x	getGroup <- trimws(strsplit(as.character(form)[3], "[\|]\|[/]")[[1]])
287	1x	makeSurvDataRet$group <- getGroup[length(getGroup)]
288	1x	makeSurvDataRet$x <- getGroup[1]
289	1x	out[["df"]] <- df
290		}
291		#* `make main survival formula`
292	3x	x <- makeSurvDataRet$x
293	3x	group <- makeSurvDataRet$group
294	3x	if (is.null(group) \|\| length(unique(df[[group]])) == 1) {
295	1x	formula <- stats::as.formula(paste0("Surv(", x, ", event) ~ 1"))
296		} else {
297	2x	formula <- stats::as.formula(paste0("Surv(", x, ", event) ~ 1 + group"))
298		}
299	3x	out[["formula"]][["f1"]] <- formula
300		#* `collect additional formulas`
301	3x	if (!is.null(anc)) {
302	1x	out[["formula"]][["f2"]] <- anc
303		} else {
304	2x	out[["formula"]][["f2"]] <- NULL
305		}
306
307		#* `return all`
308	3x	out[["pcvrForm"]] <- form
309	3x	out[["distribution"]] <- model
310	3x	return(out)
311		}

1		#' Ease of use nlrq starter function for 6 growth model parameterizations
2		#'
3		#' Internal to growthSS
4		#'
5		#' @examples
6		#'
7		#' simdf <- growthSim("logistic",
8		#' n = 20, t = 25,
9		#' params = list("A" = c(200, 160), "B" = c(13, 11), "C" = c(3, 3.5))
10		#' )
11		#'
12		#' ss <- .mgcvSS(model = "gam", form = y ~ time \| id / group, df = simdf)
13		#' names(ss) # formula, df, pcvrForm
14		#'
15		#' @keywords internal
16		#' @noRd
17
18		.mgcvSS <- function(model = "gam", form, df) {
19		#* `parse form argument`
20	3x	parsed_form <- .parsePcvrForm(form, df)
21	3x	y <- parsed_form$y
22	3x	x <- parsed_form$x
23	3x	group <- parsed_form$group
24	3x	USEGROUP <- parsed_form$USEG
25	3x	if (parsed_form$USEID) {
26	2x	message(paste0("Individual is not used with type = 'gam'."))
27		}
28	3x	df <- parsed_form$data
29
30	3x	if (USEGROUP) {
31	2x	df[[group]] <- factor(df[[group]])
32	2x	df[[paste0(group, "_numericLabel")]] <- unclass(df[[group]])
33		}
34		#* `assemble gam formula`
35	3x	if (USEGROUP) {
36	2x	gam_form <- stats::as.formula(paste0(y, "~0+", group, "+s(", x, ", by=", group, ")"))
37		} else {
38	1x	gam_form <- stats::as.formula(paste0(y, "~0+s(", x, ")"))
39		}
40		#* `return list`
41	3x	out <- list()
42	3x	out[["formula"]] <- gam_form
43	3x	out[["df"]] <- df
44	3x	out[["pcvrForm"]] <- form
45	3x	return(out)
46		}

1		#' Ease of use multi-value trait model helper function.
2		#'
3		#' This function provides a simplified interface to modeling multi-value traits using \link{growthSS}.
4		#' Output from this should be passed to \link{fitGrowth} to fit the specified model.
5		#'
6		#' @param form A formula similar to \code{label \| value ~ time + id/group} where label is a column
7		#' of histogram bins, value is the counts within those bins, time is an optional time variable,
8		#' id identifies an individual, and group contains the treatment groups.
9		#' @param sigma Distributional models passed to \link{growthSS}.
10		#' @param df Data passed to \link{growthSS}.
11		#' @param pars Parameters to vary, passed to \link{growthSS}.
12		#' @param start Starting values or priors, passed to \link{growthSS}.
13		#' @param type Backend to use, passed to \link{growthSS}.
14		#' @param tau Quantile to model, passed to \link{growthSS}.
15		#' @param hierarchy Formulae describing any hierarchical models, see \link{growthSS}.
16		#' @param spectral_index Optionally, a spectral index
17		#' \href{https://plantcv.readthedocs.io/en/stable/spectral_index/}{from those calculated by PlantCV}.
18		#' If this is given then the appropriate truncation and model family (if applicable)
19		#' will be included for the index you are using without you having to write it in the formula.
20		#' @keywords multi-value
21		#' @return A named list of plots showing prior distributions that \code{growthSS} would use,
22		#' optionally with a plot of simulated growth curves using draws from those priors.
23		#'
24		#' @examples
25		#' set.seed(123)
26		#' mv_df <- mvSim(dists = list(rnorm = list(mean = 100, sd = 30)), wide = FALSE)
27		#' mv_df$group <- rep(c("a", "b"), times = 900)
28		#' mv_df <- mv_df[mv_df$value > 0, ]
29		#' mv_df$label <- as.numeric(gsub("sim_", "", mv_df$variable))
30		#'
31		#' ss1 <- mvSS(
32		#' model = "linear", form = label \| value ~ group, df = mv_df,
33		#' start = list("A" = 5), type = "brms", spectral_index = "ci_rededge"
34		#' )
35		#' \donttest{
36		#' mod1 <- fitGrowth(ss1, backend = "cmdstanr", iter = 1000, chains = 1, cores = 1)
37		#' growthPlot(mod1, ss1$pcvrForm, df = ss1$df)
38		#' }
39		#'
40		#' # when the model is longitudinal the same model is possible with growthSS
41		#'
42		#' m1 <- mvSim(
43		#' dists = list(
44		#' rnorm = list(mean = 100, sd = 30),
45		#' rnorm = list(mean = 110, sd = 25),
46		#' rnorm = list(mean = 120, sd = 20),
47		#' rnorm = list(mean = 135, sd = 15)
48		#' ),
49		#' wide = FALSE, n = 6
50		#' )
51		#' m1$time <- rep(1:4, times = 6 * 180)
52		#' m2 <- mvSim(
53		#' dists = list(
54		#' rnorm = list(mean = 85, sd = 25),
55		#' rnorm = list(mean = 95, sd = 20),
56		#' rnorm = list(mean = 105, sd = 15),
57		#' rnorm = list(mean = 110, sd = 15)
58		#' ),
59		#' wide = FALSE, n = 6
60		#' )
61		#' m2$time <- rep(1:4, times = 6 * 180)
62		#' mv_df2 <- rbind(m1, m2)
63		#' mv_df2$group <- rep(c("a", "b"), each = 4320)
64		#' mv_df2 <- mv_df2[mv_df2$value > 0, ]
65		#' mv_df2$label <- as.numeric(gsub("sim_", "", mv_df2$variable))
66		#'
67		#' ss_mv1 <- mvSS(
68		#' model = "linear", form = label \| value ~ time \| group, df = mv_df2,
69		#' start = list("A" = 50), type = "brms", spectral_index = "ci_rededge"
70		#' )
71		#' ss_mv2 <- growthSS(
72		#' model = "skew_normal: linear",
73		#' form = label \| resp_weights(value) + trunc(lb = -1, ub = Inf) ~ time \| group,
74		#' df = mv_df2, start = list("A" = 50)
75		#' )
76		#' identical(names(ss_mv1), names(ss_mv2))
77		#' # ignoring environments and other such details these are identical except for the
78		#' # function call.
79		#' unlist(lapply(names(ss_mv1), function(nm) {
80		#' if (!identical(ss_mv1[[nm]], ss_mv2[[nm]],
81		#' ignore.environment = TRUE,
82		#' ignore.srcref = TRUE
83		#' )) {
84		#' if (!identical(as.character(ss_mv1[[nm]]), as.character(ss_mv2[[nm]]))) {
85		#' nm
86		#' }
87		#' }
88		#' }))
89		#'
90		#' \donttest{
91		#' m2 <- fitGrowth(ss_mv1, backend = "cmdstanr", iter = 1000, chains = 1, cores = 1)
92		#' growthPlot(m2, ss_mv1$pcvrForm, df = ss_mv1$df)
93		#' }
94		#'
95		#' @export
96
97		mvSS <- function(model = "linear", form, sigma = NULL, df, start = NULL,
98		pars = NULL, type = "brms", tau = 0.5, hierarchy = NULL,
99		spectral_index = c(
100		"none", "ari", "ci_rededge", "cri550", "cri700",
101		"egi", "evi", "gdvi", "mari", "mcari", "mtci", "ndre",
102		"ndvi", "pri", "psnd_chlorophyll_a", "psnd_chlorophyll_b",
103		"psnd_caroteniods", "psri", "pssr_chlorophyll_a",
104		"pssr_chlorophyll_b", "pssr_caroteniods", "rgri",
105		"rvsi", "savi", "sipi", "sr", "vari", "vi_green", "wi",
106		"fvfm", "fqfm"
107		)) {
108		#* `get spectral index helper function`
109		#* spectral index function should just return truncation and family, then there will be a separate
110		#* function that applies those changes to the form argument.
111	2x	pcvrForm <- form
112	2x	spec_helper <- get(paste0(".", spectral_index, "_mvss_hlp"))
113		#* `run spectral index helper function`
114	2x	spec_helper_res <- spec_helper()
115	2x	family <- spec_helper_res$family
116	2x	trunc <- spec_helper_res$trunc
117		#* `run formula cleaner`
118		#* This should return the final, usable formula and model
119	2x	form_res <- .mv_ss_formula_builder(form, family, trunc, type, model, df)
120	2x	form <- form_res$formula
121	2x	weights <- form_res$weights
122	2x	model <- form_res$model
123	2x	df <- form_res$df
124	2x	has_x_var <- form_res$has_x_var
125	2x	if (has_x_var) {
126		#* `if time is a variable, call growthSS with new model formula`
127	1x	out <- growthSS(
128	1x	model = model, form = form, sigma = sigma, df = df, start = start,
129	1x	pars = pars, type = type, tau = tau, hierarchy = hierarchy
130		)
131		} else {
132		#* `if x variable is missing then call mvSS_helpers to make simple model`
133		#* this is the tricky part I think. but on the other hand if time is missing then it's
134		#* really only one option for what happens next, so maybe it's not bad. Model is basically
135		#* ignored in this case.
136	1x	form_fun <- get(paste0(".", type, "_mvss"))
137	1x	out <- form_fun(form, df, start, family, model, tau, weights, pcvrForm)
138		}
139	2x	out$call <- match.call()
140	2x	return(out)
141		}
142
143
144		#' `mvSS_formula_builder`
145		#' add family, truncation, and weights to formula
146		#' @keywords internal
147		#' @noRd
148
149		.mv_ss_formula_builder <- function(form, family, trunc, type, model, df) {
150	2x	form_char <- as.character(form)
151	2x	has_x_var <- TRUE
152	2x	parsed <- .parsePcvrForm(form, df)
153	2x	df <- parsed$data
154	2x	if (!is.numeric(df[, parsed$x]) && !parsed$USEG && !parsed$USEID) {
155	1x	has_x_var <- FALSE # treating single element of RHS as grouping
156		}
157	2x	weights <- NULL
158		#* for brms backend make weights in formula
159	2x	if (type == "brms") {
160	2x	form_char[2] <- paste0(gsub("[\|]", "\| resp_weights(", form_char[2]), ")")
161	2x	if (any(!is.infinite(trunc))) {
162	2x	form_char[2] <- paste0(form_char[2], " + trunc(lb = ", trunc[1], ", ub = ", trunc[2], ")")
163		}
164	2x	if (!grepl("[:]", model)) {
165	2x	model <- paste0(family, ": ", model)
166		}
167		} else {
168		#* for other backends save weights variable
169	!	lhs <- trimws(strsplit(form_char[2], "[\|]")[[1]])
170	!	weights <- lhs[2]
171	!	form_char[2] <- lhs[1]
172		}
173	2x	parsed_form <- as.formula(paste0(form_char[c(2, 1, 3)], collapse = ""))
174	2x	return(list(
175	2x	"formula" = parsed_form,
176	2x	"weights" = weights,
177	2x	"model" = model,
178	2x	"df" = df,
179	2x	"has_x_var" = has_x_var
180		))
181		}
182
183		#' `mvSS specified simple model helper functions`
184
185		#' @keywords internal
186		#' @noRd
187
188		.brms_mvss <- function(form = NULL, df = NULL, start = NULL, family = NULL, model = NULL, tau = NULL,
189		weights = NULL, pcvrform = NULL) {
190	1x	out <- list()
191		#* `Make bayesian non-linear formula`
192	1x	bf1 <- as.formula(paste0(as.character(form)[2], "~ A"))
193	1x	bf2 <- as.formula(paste0("A ~ 0 + ", as.character(form)[3]))
194
195	1x	out[["formula"]] <- brms::bf(bf1, bf2, nl = TRUE)
196	1x	out[["prior"]] <- .makePriors(
197	1x	priors = start,
198	1x	pars = "A", df = df,
199	1x	group = "dummyGroup", # group from parse pcvr form should be dummy
200	1x	USEGROUP = FALSE,
201	1x	sigma = FALSE, family = family,
202	1x	formula = out[["formula"]]
203		)
204	1x	out[["initfun"]] <- 0 # no fancy initialization here
205	1x	out[["df"]] <- df
206	1x	out[["family"]] <- family
207	1x	out[["pcvrForm"]] <- form
208	1x	out[["type"]] <- "brms"
209	1x	out[["model"]] <- trimws(gsub(".*:", "", model))
210	1x	return(out)
211		}
212
213		#' @keywords internal
214		#' @noRd
215
216		.nls_mvss <- function(form = NULL, df = NULL, start = NULL, family = NULL, model = NULL, tau = NULL,
217		weights = NULL, pcvrForm = NULL) {
218	!	out <- list()
219	!	out[["formula"]] <- form
220	!	out[["start"]] <- NULL
221	!	out[["df"]] <- df
222	!	out[["pcvrForm"]] <- pcvrForm
223	!	out[["type"]] <- "lm"
224	!	out[["model"]] <- trimws(gsub(".*:", "", model))
225	!	out[["weights"]] <- df[[weights]]
226	!	return(out)
227		}
228
229		#' @keywords internal
230		#' @noRd
231
232		.nlrq_mvss <- function(form = NULL, df = NULL, start = NULL, family = NULL, model = NULL, tau = NULL,
233		weights = NULL, pcvrform = NULL) {
234	!	out <- list()
235	!	out[["formula"]] <- form
236	!	out[["start"]] <- NULL
237	!	out[["df"]] <- df
238	!	out[["pcvrForm"]] <- pcvrform
239	!	out[["type"]] <- "rq"
240	!	out[["model"]] <- trimws(gsub(".*:", "", model))
241	!	out[["taus"]] <- tau
242	!	out[["weights"]] <- df[[weights]]
243	!	return(out)
244		}
245
246		#' `Spectral Index helpers`
247
248		#' @keywords internal
249		#' @noRd
250		.none_mvss_hlp <- function() {
251	!	truncation <- c(Inf, Inf) # unbounded
252	!	family <- "student" # if not specified then leave as student T per default
253	!	return(list("trunc" = truncation, "family" = family))
254		}
255		#' @keywords internal
256		#' @noRd
257		.ari_mvss_hlp <- function() {
258	!	truncation <- c(Inf, Inf)
259	!	family <- "skew_normal"
260	!	return(list("trunc" = truncation, "family" = family))
261		}
262		#' @keywords internal
263		#' @noRd
264		.ci_rededge_mvss_hlp <- function() {
265	2x	truncation <- c(-1, Inf)
266	2x	family <- "skew_normal"
267	2x	return(list("trunc" = truncation, "family" = family))
268		}
269		#' @keywords internal
270		#' @noRd
271		.cri550_mvss_hlp <- function() {
272	!	truncation <- c(Inf, Inf)
273	!	family <- "skew_normal"
274	!	return(list("trunc" = truncation, "family" = family))
275		}
276		#' @keywords internal
277		#' @noRd
278		.cri700_mvss_hlp <- function() {
279	!	truncation <- c(Inf, Inf)
280	!	family <- "skew_normal"
281	!	return(list("trunc" = truncation, "family" = family))
282		}
283		#' @keywords internal
284		#' @noRd
285		.egi_mvss_hlp <- function() {
286	!	truncation <- c(-1, 2)
287	!	family <- "skew_normal"
288	!	return(list("trunc" = truncation, "family" = family))
289		}
290		#' @keywords internal
291		#' @noRd
292		.evi_mvss_hlp <- function() {
293	!	truncation <- c(Inf, Inf)
294	!	family <- "skew_normal"
295	!	return(list("trunc" = truncation, "family" = family))
296		}
297		#' @keywords internal
298		#' @noRd
299		.gdvi_mvss_hlp <- function() {
300	!	truncation <- c(-2, 2)
301	!	family <- "skew_normal"
302	!	return(list("trunc" = truncation, "family" = family))
303		}
304		#' @keywords internal
305		#' @noRd
306		.mari_mvss_hlp <- function() {
307	!	truncation <- c(Inf, Inf)
308	!	family <- "skew_normal"
309	!	return(list("trunc" = truncation, "family" = family))
310		}
311		#' @keywords internal
312		#' @noRd
313		.mcari_mvss_hlp <- function() {
314	!	truncation <- c(Inf, Inf)
315	!	family <- "skew_normal"
316	!	return(list("trunc" = truncation, "family" = family))
317		}
318		#' @keywords internal
319		#' @noRd
320		.mtci_mvss_hlp <- function() {
321	!	truncation <- c(Inf, Inf)
322	!	family <- "skew_normal"
323	!	return(list("trunc" = truncation, "family" = family))
324		}
325		#' @keywords internal
326		#' @noRd
327		.ndre_mvss_hlp <- function() {
328	!	truncation <- c(-1, 1)
329	!	family <- "skew_normal"
330	!	return(list("trunc" = truncation, "family" = family))
331		}
332		#' @keywords internal
333		#' @noRd
334		.ndvi_mvss_hlp <- function() {
335	!	truncation <- c(-1, 1)
336	!	family <- "skew_normal"
337	!	return(list("trunc" = truncation, "family" = family))
338		}
339		#' @keywords internal
340		#' @noRd
341		.pri_mvss_hlp <- function() {
342	!	truncation <- c(-1, 1)
343	!	family <- "skew_normal"
344	!	return(list("trunc" = truncation, "family" = family))
345		}
346		#' @keywords internal
347		#' @noRd
348		.psnd_chlorophyll_a_mvss_hlp <- function() {
349	!	truncation <- c(-1, 1)
350	!	family <- "skew_normal"
351	!	return(list("trunc" = truncation, "family" = family))
352		}
353		#' @keywords internal
354		#' @noRd
355		.psnd_chlorophyll_b_mvss_hlp <- function() {
356	!	truncation <- c(-1, 1)
357	!	family <- "skew_normal"
358	!	return(list("trunc" = truncation, "family" = family))
359		}
360		#' @keywords internal
361		#' @noRd
362		.psnd_caroteniods_mvss_hlp <- function() {
363	!	truncation <- c(-1, 1)
364	!	family <- "skew_normal"
365	!	return(list("trunc" = truncation, "family" = family))
366		}
367		#' @keywords internal
368		#' @noRd
369		.psri_mvss_hlp <- function() {
370	!	truncation <- c(Inf, Inf)
371	!	family <- "skew_normal"
372	!	return(list("trunc" = truncation, "family" = family))
373		}
374		#' @keywords internal
375		#' @noRd
376		.pssr_chlorophyll_a_mvss_hlp <- function() {
377	!	truncation <- c(-1, 1)
378	!	family <- "skew_normal"
379	!	return(list("trunc" = truncation, "family" = family))
380		}
381		#' @keywords internal
382		#' @noRd
383		.pssr_chlorophyll_b_mvss_hlp <- function() {
384	!	truncation <- c(-1, 1)
385	!	family <- "skew_normal"
386	!	return(list("trunc" = truncation, "family" = family))
387		}
388		#' @keywords internal
389		#' @noRd
390		.pssr_caroteniods_mvss_hlp <- function() {
391	!	truncation <- c(-1, 1)
392	!	family <- "skew_normal"
393	!	return(list("trunc" = truncation, "family" = family))
394		}
395		#' @keywords internal
396		#' @noRd
397		.rgri_mvss_hlp <- function() {
398	!	truncation <- c(0, Inf)
399	!	family <- "skew_normal"
400	!	return(list("trunc" = truncation, "family" = family))
401		}
402		#' @keywords internal
403		#' @noRd
404		.rvsi_mvss_hlp <- function() {
405	!	truncation <- c(-1, 1)
406	!	family <- "skew_normal"
407	!	return(list("trunc" = truncation, "family" = family))
408		}
409		#' @keywords internal
410		#' @noRd
411		.savi_mvss_hlp <- function() {
412	!	truncation <- c(-1.2, 1.2)
413	!	family <- "skew_normal"
414	!	return(list("trunc" = truncation, "family" = family))
415		}
416		#' @keywords internal
417		#' @noRd
418		.sipi_mvss_hlp <- function() {
419	!	truncation <- c(Inf, Inf)
420	!	family <- "skew_normal"
421	!	return(list("trunc" = truncation, "family" = family))
422		}
423		#' @keywords internal
424		#' @noRd
425		.sr_mvss_hlp <- function() {
426	!	truncation <- c(0, Inf)
427	!	family <- "skew_normal"
428	!	return(list("trunc" = truncation, "family" = family))
429		}
430		#' @keywords internal
431		#' @noRd
432		.vari_mvss_hlp <- function() {
433	!	truncation <- c(Inf, Inf)
434	!	family <- "skew_normal"
435	!	return(list("trunc" = truncation, "family" = family))
436		}
437		#' @keywords internal
438		#' @noRd
439		.vi_green_mvss_hlp <- function() {
440	!	truncation <- c(-1, 1)
441	!	family <- "skew_normal"
442	!	return(list("trunc" = truncation, "family" = family))
443		}
444		#' @keywords internal
445		#' @noRd
446		.wi_mvss_hlp <- function() {
447	!	truncation <- c(0, Inf)
448	!	family <- "skew_normal"
449	!	return(list("trunc" = truncation, "family" = family))
450		}
451		#' @keywords internal
452		#' @noRd
453		.fvfm_mvss_hlp <- function() {
454	!	truncation <- c(0, 1)
455	!	family <- "skew_normal"
456	!	return(list("trunc" = truncation, "family" = family))
457		}
458		#' @keywords internal
459		#' @noRd
460		.fqfm_mvss_hlp <- function() {
461	!	truncation <- c(0, 1)
462	!	family <- "skew_normal"
463	!	return(list("trunc" = truncation, "family" = family))
464		}

1		#' Network analysis of a distance matrix
2		#'
3		#' @description Easy igraph use with pcv.emd output
4		#'
5		#'
6		#' @param emd A long dataframe as returned by pcv.emd.
7		#' Currently this function is only made to work with dataframe output,
8		#' not distance matrix output.
9		#' @param meta Metadata to be carried from pcv.emd output into the network,
10		#' defaults to NULL which will use all metadata.
11		#' Type conversion will be attempted for these columns.
12		#' @param dissim Logical, should the distCol be inverted to make a dissimilarity value?
13		#' @param distCol The name of the column containing distances/dissimilarities.
14		#' Defaults to "emd" for compatability with pcv.emd
15		#' @param filter This can be either a numeric (0.5) in which case it is taken as
16		#' a filter where only edges with values greater than or equal to that number are
17		#' kept or a character string ("0.5") in which case the strongest X percentage of edges are kept.
18		#' This defaults to 0.5 which does some filtering, although that should not be considered
19		#' the best behavior for every setting. If this is NULL then your network will be
20		#' almost always be a single blob, if set too high there will be very few nodes.
21		#' Note that this filtering happens after converting to dissimilarity if dissim=TRUE.
22		#' @param direction Direction of filtering, can be either "greater" or "lesser".
23		#' @import ggplot2
24		#' @import igraph
25		#' @importFrom utils type.convert
26		#' @importFrom stats quantile
27		#'
28		#' @keywords emd multi-value-trait network
29		#' @examples
30		#'
31		#' library(extraDistr)
32		#' dists <- list(
33		#' rmixnorm = list(mean = c(70, 150), sd = c(15, 5), alpha = c(0.3, 0.7)),
34		#' rnorm = list(mean = 90, sd = 3)
35		#' )
36		#' x <- mvSim(
37		#' dists = dists, n_samples = 5, counts = 1000,
38		#' min_bin = 1, max_bin = 180, wide = TRUE
39		#' )
40		#' emd_df <- pcv.emd(x,
41		#' cols = "sim", reorder = c("group"), mat = FALSE,
42		#' plot = FALSE, parallel = 1
43		#' )
44		#' net <- pcv.net(emd_df, meta = "group")
45		#' net2 <- pcv.net(emd_df, meta = "group", filter = "0.9", direction = "lesser")
46		#'
47		#' @return Returns a list containing three elements:
48		#' \code{nodes}: A dataframe of node data.
49		#' \code{edges}: A dataframe of edges between nodes.
50		#' \code{graph}: The network as an igraph object
51		#'
52		#' @export
53		#'
54
55		pcv.net <- function(emd = NULL, meta = NULL, dissim = TRUE, distCol = "emd", filter = 0.5,
56		direction = "greater") {
57	8x	if (is.data.frame(emd)) {
58		#* convert to dissimilarity if metric is similarity
59	8x	if (dissim) {
60	8x	emd[[distCol]] <- 1 / emd[[distCol]]
61	8x	emd[[distCol]] <- ifelse(is.infinite(emd[[distCol]]) \| is.na(emd[[distCol]]), 0, emd[[distCol]])
62		}
63		#* filter for edge strength
64	8x	if (!is.null(filter)) {
65	8x	if (is.character(filter)) {
66	5x	filter <- quantile(emd[[distCol]], probs = as.numeric(filter))
67		}
68	8x	if (match.arg(direction, c("greater", "lesser")) == "greater") {
69	7x	emd <- emd[emd[[distCol]] > filter, ]
70		} else {
71	1x	emd <- emd[emd[[distCol]] < filter, ]
72		}
73		}
74		#* turn long data into a graph and extract nodes/edges
75	8x	g <- igraph::graph_from_data_frame(emd, directed = FALSE)
76		} else {
77	!	stop("emd must be a dataframe.")
78		}
79	8x	if (is.null(meta)) {
80	5x	meta <- unique(sub("_i$\|_j$", "", colnames(emd)[grepl("_i$\|_j$", colnames(emd))]))
81		}
82
83	8x	gg <- as.data.frame(igraph::layout_nicely(g))
84	8x	both <- igraph::as_data_frame(g, "both")
85	8x	gg$index <- both$vertices$name
86	8x	eg <- both$edges
87		#* link metadata to nodes
88	8x	metaIndex <- lapply(meta, function(m) which(grepl(m, colnames(eg))))
89	8x	newCols <- (ncol(gg) + 1):(ncol(gg) + length(meta))
90	8x	gg[, newCols] <- lapply(metaIndex, function(m) {
91	10x	i <- m[[1]]
92	10x	j <- m[[2]]
93	10x	f <- eg[[i]][match(gg$index, eg$from)]
94	10x	to <- eg[[j]][match(gg$index, eg$to)]
95	10x	to[which(is.na(to))] <- f[which(is.na(to))]
96	10x	to
97	8x	}) # this can be NA if there is no 'from' edge connected to a node, so check 'to' edges as well.
98	8x	colnames(gg)[newCols] <- meta
99	8x	gg[, newCols] <- type.convert(gg[, newCols], as.is = TRUE)
100
101		#* Calculate network metrics
102	8x	gg$betweenness <- igraph::betweenness(g)
103	8x	gg$degree <- igraph::degree(g)
104	8x	igraph::E(g)$weight <- eg[[distCol]] + 0.1
105	8x	gg$strength <- igraph::strength(g)
106	8x	gg$harmonic_centrality <- igraph::harmonic_centrality(g)
107	8x	gg$eigen_centrality <- igraph::eigen_centrality(g)[[1]]
108	8x	gg$authority_score <- igraph::authority_score(g)[[1]]
109	8x	gg$page_rank <- igraph::page_rank(g)[[1]]
110		#* add coordinates for plotting edges
111	8x	eg$from.x <- gg$V1[match(eg$from, gg$index)]
112	8x	eg$from.y <- gg$V2[match(eg$from, gg$index)]
113	8x	eg$to.x <- gg$V1[match(eg$to, gg$index)]
114	8x	eg$to.y <- gg$V2[match(eg$to, gg$index)]
115	8x	return(list("nodes" = gg, "edges" = eg, "graph" = g))
116		}

1		#' @description
2		#' Internal function for calculating \alpha and \beta of a beta distributed p (probability) parameter
3		#' in a beta-binomial conjugate distribution.
4		#'
5		#' @param s1 A named list of integer data containing number of successes and number of trials.
6		#' @examples
7		#' .conj_binomial_sv(
8		#' s1 = list(successes = c(15, 14, 16, 11), trials = 20),
9		#' priors = list(a = c(0.5, 0.5), b = c(0.5, 0.5)),
10		#' plot = FALSE, cred.int.level = 0.95
11		#' )
12		#' @keywords internal
13		#' @noRd
14
15		.conj_binomial_sv <- function(s1 = NULL, priors = NULL,
16		plot = FALSE, support = NULL, cred.int.level = NULL,
17		calculatingSupport = FALSE) {
18		#* `check stopping conditions`
19	8x	s1 <- .conj_binomial_formatter(s1)
20		#* `separate data into counts and trials`
21	8x	s1_successes <- s1$successes
22	8x	s1_trials <- s1$trials
23		#* `Replicate trials numbers if too short`
24	8x	if (length(s1_trials) < length(s1_successes)) {
25	4x	s1_trials <- rep(s1_trials, length(s1_successes))
26		}
27
28		#* `make default prior if none provided`
29		#* `p parameter is beta distributed`
30	8x	if (is.null(priors)) {
31	4x	priors <- list(a = 0.5, b = 0.5)
32		}
33		#* `Define dense Support`
34		#* `p parameter is beta distributed`
35	8x	if (is.null(support) && calculatingSupport) {
36	4x	return(c(0.0001, 0.9999))
37		}
38	4x	out <- list()
39		#* `Update priors with observed counts`
40	4x	a1_prime <- priors$a[1] + sum(s1_successes)
41	4x	b1_prime <- priors$b[1] + sum(s1_trials) - sum(s1_successes)
42
43		#* `calculate density over support``
44	4x	dens1 <- dbeta(support, a1_prime, b1_prime)
45	4x	pdf1 <- dens1 / sum(dens1)
46
47		#* `calculate highest density interval`
48	4x	hdi1 <- qbeta(c((1 - cred.int.level) / 2, (1 - ((1 - cred.int.level) / 2))), a1_prime, b1_prime)
49
50		#* `calculate highest density estimate``
51	4x	hde1 <- .betaHDE(a1_prime, b1_prime)
52		#* `save summary and parameters`
53	4x	out$summary <- data.frame(HDE_1 = hde1, HDI_1_low = hdi1[1], HDI_1_high = hdi1[2])
54	4x	out$posterior$a <- a1_prime
55	4x	out$posterior$b <- b1_prime
56		#* `Make Posterior Draws`
57	4x	out$posteriorDraws <- rbeta(10000, a1_prime, b1_prime)
58	4x	out$pdf <- pdf1
59		#* `keep data for plotting`
60	4x	if (plot) {
61	2x	out$plot_df <- data.frame(
62	2x	"range" = support, "prob" = pdf1,
63	2x	"sample" = rep("Sample 1", length(support))
64		)
65		}
66	4x	return(out)
67		}
68
69		#' Error condition handling helper function
70		#' @param s1 The sample given to conjugate and conjugate_binomial_sv
71		#' @keywords internal
72		#' @noRd
73
74		.conj_binomial_formatter <- function(s1) {
75		#* `Check data for stopping conditions`
76	11x	if (any(unlist(s1) < 0)) {
77	1x	stop(paste0(
78	1x	"Binomial method requires successes and trials in sample data",
79	1x	" as a list of two positive integer vectors. See examples."
80		))
81		}
82	10x	if (length(s1) != 2) {
83	1x	stop(paste0(
84	1x	"Binomial method requires successes and trials in sample data",
85	1x	" as a list of two integer vectors. See examples."
86		))
87		}
88	9x	if (any(is.null(names(s1)), names(s1) != c("successes", "trials"))) {
89	1x	message("Assuming sample data is in order 'successes', 'trials'.")
90	1x	names(s1) <- c("successes", "trials")
91		}
92	9x	return(s1)
93		}

1		#' Multi Value Trait simulating function
2		#'
3		#' @description mvSim can be used to simulate data for example models/plots.
4		#'
5		#' @param n_samples Number of samples per distribution to generate. Defaults to 10, can be >1L.
6		#' @param counts Number of counts per histogram, defaults to 1000.
7		#' @param max_bin The number of bins to return. Note that this is also the max value that will be
8		#' accepted in the distribution functions, with higher numbers being shrunk to this value.
9		#' Defaults to 180.
10		#' @param min_bin The minumum bin number. This can be thought of as the minimum value that will
11		#' be accepted in the distribution functions, with lower numbers being raised to this value.
12		#' Note that bin arguments are both ignored in the case of "rbeta" and treated as 0,1.
13		#' @param dists A list of lists, with names corresponding to random deviate generating functions
14		#' and arguments to the function in the list values (see examples). Note that the n argument
15		#' does not need to be provided.
16		#' @param wide Boolean, should data be returned in wide format (the default)?
17		#' If FALSE then long data is returned.
18		#' @param binwidth How wide should bins be? Defaults to 1.
19		#' @keywords multi-value
20		#' @return Returns a dataframe of example multi-value trait data simulated from specified distributions.
21		#'
22		#' @importFrom graphics hist
23		#' @importFrom data.table melt as.data.table
24		#'
25		#' @examples
26		#'
27		#' library(extraDistr) # for rmixnorm
28		#' library(ggplot2)
29		#' n_samples = 10
30		#' counts = 1000
31		#' min_bin = 0
32		#' max_bin = 180
33		#' dists <- list(
34		#' rmixnorm = list(mean = c(70, 150), sd = c(15, 5), alpha = c(0.3, 0.7)),
35		#' rnorm = list(mean = 90, sd = 3)
36		#' )
37		#' x <- mvSim(dists = dists, wide = FALSE)
38		#' dim(x)
39		#' x2 <- mvSim(dists = dists)
40		#' dim(x2)
41		#'
42		#' ggplot(x, aes(
43		#' x = as.numeric(sub("sim_", "", variable)),
44		#' y = value, group = interaction(group, id), fill = group
45		#' )) +
46		#' geom_col(position = "identity", alpha = 0.25) +
47		#' pcv_theme() +
48		#' labs(x = "bin")
49		#'
50		#' @export
51
52		mvSim <- function(dists = list(rnorm = list(mean = 100, sd = 15)),
53		n_samples = 10, counts = 1000, min_bin = 1, max_bin = 180, wide = TRUE,
54		binwidth = 1) {
55	47x	if (length(n_samples) == 1) {
56	41x	n_samples <- rep(n_samples, length(dists))
57		}
58	47x	vecs <- .makeVecs(dists, counts, n_samples)
59	47x	out <- .simFreqs(vecs, max_bin, min_bin, binwidth)
60	47x	if (!wide) {
61	8x	out$id <- seq_len(nrow(out))
62	8x	out <- as.data.frame(data.table::melt(data.table::as.data.table(out), id.vars = c("group", "id")))
63		}
64	47x	return(out)
65		}
66
67		#' internal vector making helper function
68		#' @keywords internal
69		#' @noRd
70
71		.makeVecs <- function(dists, counts, n_samples) {
72	47x	funs <- names(dists)
73	47x	out <- lapply(seq_along(funs), function(i) {
74	89x	f <- funs[i]
75	89x	fun <- match.fun(f)
76	89x	dists[[i]]$n <- counts
77	89x	lapply(1:n_samples[i], function(e) {
78	2011x	do.call(fun, args = dists[[i]])
79		})
80		})
81	47x	names(out) <- names(dists)
82	47x	return(out)
83		}
84
85		#' internal histogram making helper function
86		#' @keywords internal
87		#' @noRd
88
89		.simFreqs <- function(vecs, max_bin, min_bin, binwidth) {
90	47x	do.call(rbind, lapply(seq_along(vecs), function(i) {
91	89x	vecName <- names(vecs)[i]
92	89x	vec <- vecs[[i]]
93	89x	do.call(rbind, lapply(vec, function(v) {
94	2011x	if (vecName == "rbeta") {
95	170x	v[v > 1] <- 1
96	170x	v[v < 0] <- 0
97	170x	s1 <- hist(v, breaks = seq(0, 1, length.out = 100), plot = FALSE)$counts
98	170x	s1d <- as.data.frame(cbind(data.frame(vecName), matrix(s1, nrow = 1)))
99	170x	colnames(s1d) <- c("group", paste0("sim_", seq(0.01, 0.99, 0.01)))
100		} else {
101	1841x	v[v > max_bin] <- max_bin
102	1841x	v[v < min_bin] <- min_bin
103	1841x	s1 <- hist(v, breaks = seq(min_bin, (max_bin + binwidth), binwidth), plot = FALSE)$counts
104	1841x	s1d <- as.data.frame(cbind(data.frame(vecName), matrix(s1, nrow = 1)))
105	1841x	colnames(s1d) <- c("group", paste0("sim_", seq(min_bin, max_bin, binwidth)))
106		}
107	2011x	s1d
108		}))
109		}))
110		}

1		#' Calculate pseudo water use efficiency from phenotype and watering data
2		#'
3		#' @description Rate based water use efficiency (WUE) is the change in biomass per unit of water
4		#' metabolized. Using image based phenotypes and watering data we can calculate pseudo-WUE (pwue) over
5		#' time. Here area_pixels is used as a proxy for biomass and transpiration is approximated using
6		#' watering data. The equation is then
7		#' \eqn{
8		#' \frac{P_{t} - P_{t-1}}{W_{t_{end-1}}-W_{t_{start}} }}{P_[t] - P_[t-1] / W_[t_(end-1)]-W_[t_start]
9		#' },
10		#' where P is the phenotype and W is the weight before watering.
11		#'
12		#' Absolute value based WUE is the amount of water used to sustain a plants biomass over a given period.
13		#' The equation is then
14		#' \eqn{\frac{P_{t}}{W_{t_{end-1}}-W_{t_{start}} }}{P_[t] / W_[t_(end-1)]-W_[t_start]}
15		#'
16		#' @param df Dataframe containing wide single-value phenotype data.
17		#' This should already be aggregated to one row per plant per day (angles/rotations combined).
18		#' @param w Watering data as returned from bw.water.
19		#' @param pheno Phenotype column name, defaults to "area_pixels"
20		#' @param time Variable(s) that identify a plant on a given day.
21		#' Defaults to \code{c("barcode", "DAS")}.
22		#' @param id Variable(s) that identify a plant over time. Defaults to \code{"barcode"}.
23		#' @param offset Optionally you can specify how long before imaging a watering should not be taken into
24		#' account. This defaults to 0, meaning that if a plant were watered directly before being imaged then
25		#' that water would be counted towards WUE between the current image and the prior one.
26		#' This argument is taken to be in seconds.
27		#' @param waterCol Column containing watering amounts in \code{w}. This defaults to "watering_amount".
28		#' @param method Which method to use, options are "rate" and "abs". The "rate" method considers WUE as
29		#' the change in a phenotype divided by the amount of water added. The "abs" method considers WUE as
30		#' the amount of water used by a plant given its absolute size. The former is for questions more
31		#' related to efficiency in using water to grow while the latter is more suited to questions about
32		#' how efficient a plant is at maintaining size given some amount of water.
33		#' @keywords WUE
34		#' @import data.table
35		#' @return A data frame containing the bellwether watering data joined
36		#' to phenotype data with new columns for change in the phenotype,
37		#' change in the pre-watering weight, and pseudo-water use efficiency (pWUE).
38		#' @examples
39		#' sim_water <- data.frame(
40		#' "barcode" = "exampleBarcode1",
41		#' "timestamp" = as.POSIXct(c(
42		#' "2023-04-13 23:28:17 UTC",
43		#' "2023-04-22 05:30:42 UTC",
44		#' "2023-05-04 18:55:38 UTC"
45		#' )),
46		#' "DAS" = c(0.000000, 8.251675, 20.810660),
47		#' "water_amount" = c(98, 12, -1)
48		#' )
49		#' sim_df <- data.frame(
50		#' "barcode" = "exampleBarcode1",
51		#' "timestamp" = as.POSIXct(c(
52		#' "2023-04-13 23:28:17 UTC",
53		#' "2023-04-22 05:30:42 UTC",
54		#' "2023-05-04 18:55:38 UTC"
55		#' )),
56		#' "DAS" = c(0.000000, 8, 20),
57		#' "area_pixels" = c(20, 1000, 1500)
58		#' )
59		#' pwue(
60		#' df = sim_df, w = sim_water, pheno = "area_pixels",
61		#' time = "timestamp", id = "barcode", offset = 0,
62		#' waterCol = "water_amount", method = "rate"
63		#' )
64		#'
65		#' pwue(
66		#' df = sim_df, w = sim_water, pheno = "area_pixels",
67		#' time = c("timestamp", "timestamp"), id = "barcode", offset = 0,
68		#' waterCol = "water_amount", method = "abs"
69		#' )
70		#'
71		#' @export
72
73		pwue <- function(df, w, pheno = "area_pixels", time = "timestamp", id = "barcode",
74		offset = 0, waterCol = "water_amount", method = "rate") {
75	3x	if (length(time) == 2) {
76	1x	time1 <- time[1]
77	1x	time2 <- time[2]
78		} else {
79	2x	time1 <- time2 <- time
80		}
81	3x	if (!time1 %in% colnames(df) \|\| !time2 %in% colnames(w)) {
82	!	stop(paste0(paste0(time, collapse = ", "), " must be in colnames of df and w"))
83		}
84
85	3x	w <- data.table::setorderv(data.table::as.data.table(w), cols = c(id, time2))
86	3x	w <- w[w[[waterCol]] > 0, ]
87	3x	df <- data.table::setorderv(data.table::as.data.table(df), cols = c(id, time1))
88	3x	ids <- intersect(unique(w[, get(id)]), unique(df[, get(id)]))
89	3x	matched_method <- match.arg(method, choices = c("rate", "abs"))
90
91	3x	if (matched_method == "abs") {
92	1x	out <- .absWUE(ids, w, df, offset, time1, time2, pheno, id, waterCol)
93	2x	} else if (matched_method == "rate") {
94	2x	out <- .rateWUE(ids, w, df, offset, time1, time2, pheno, id, waterCol)
95		}
96	3x	return(as.data.frame(out))
97		}
98
99		#' Function to calculate rate based WUE
100		#' @keywords internal
101		#' @noRd
102
103		.rateWUE <- function(ids, w, df, offset, time1, time2, pheno, id, waterCol) {
104	2x	out <- do.call(rbind, lapply(ids, function(iter_id) { # per id...
105	89x	w_i <- w[w[, get(id)] == iter_id, ]
106	89x	df_i <- df[df[, get(id)] == iter_id, ]
107		#* reorder watering and pheno data
108	89x	w_i <- data.table::setorderv(w_i, cols = c(time2))
109	89x	df_i <- data.table::setorderv(df_i, cols = c(time1))
110		#* get unique imaging times
111	89x	imaging_times <- unique(df_i[[time1]])
112		#* set water from before first image to zero so that
113		#* offset does not grab water from before imaging starts.
114	89x	w_i[[waterCol]] <- as.numeric(ifelse(w_i[[time2]] < imaging_times[1], 0, w_i[[waterCol]]))
115		#* per imaging time
116	89x	wue_i <- do.call(rbind, lapply(seq_along(imaging_times), function(t_i) {
117	1442x	start <- if (t_i == 1) {
118	1442x	NA
119		} else {
120	1353x	imaging_times[(t_i - 1)] - offset
121		}
122	1442x	startNonOffset <- if (t_i == 1) {
123	1442x	NA
124		} else {
125	1353x	imaging_times[(t_i - 1)]
126		}
127	1442x	end <- imaging_times[t_i] - offset
128	1442x	endNonOffset <- imaging_times[t_i]
129	1442x	if (!is.na(start)) {
130	1353x	w_i_t <- w_i[w_i[[time2]] > start & w_i[[time2]] < end, ]
131	1353x	total_water_i <- max(c(sum(w_i_t[[waterCol]]), 1))
132	1353x	pheno_diff <- max(c(
133	1353x	as.numeric(df_i[df_i[[time1]] == endNonOffset, get(pheno)] - df_i[
134	1353x	df_i[[time1]] == startNonOffset, get(pheno)
135	1353x	]), 0
136		))
137		} else {
138	89x	total_water_i <- NA
139	89x	pheno_diff <- NA
140		}
141
142	1442x	row <- data.frame(
143	1442x	total_water = total_water_i,
144	1442x	pheno_diff = pheno_diff,
145	1442x	start = startNonOffset,
146	1442x	end = endNonOffset,
147	1442x	timeLengthSeconds = as.numeric(end) - as.numeric(start),
148	1442x	offset = offset
149		)
150	1442x	row$pWUE <- row$pheno_diff / row$total_water
151	1442x	return(row)
152		}))
153	89x	iter_out <- cbind(df_i, wue_i)
154	89x	return(iter_out)
155		}))
156	2x	return(out)
157		}
158
159		#' Function to calculate absolute value based WUE
160		#' @keywords internal
161		#' @noRd
162
163
164		.absWUE <- function(ids, w, df, offset, time1, time2, pheno, id, waterCol) {
165	1x	out <- do.call(rbind, lapply(ids, function(iter_id) { # per id...
166	1x	w_i <- w[w[[id]] == iter_id, ]
167	1x	df_i <- df[df[[id]] == iter_id, ]
168		#* reorder watering and pheno data
169	1x	w_i <- data.table::setorderv(w_i, cols = c(time2))
170	1x	df_i <- data.table::setorderv(df_i, cols = c(time1))
171		#* get unique imaging times
172	1x	imaging_times <- unique(df_i[[time1]])
173		#* set water from before first image to zero so that offset
174		#* does not grab water from before imaging starts.
175	1x	w_i[[waterCol]] <- ifelse(w_i[[time2]] < imaging_times[1], 0, w_i[[time2]])
176		#* per imaging time
177	1x	wue_i <- do.call(rbind, lapply(seq_along(imaging_times), function(t_i) {
178	3x	start <- if (t_i == 1) {
179	3x	NA
180		} else {
181	2x	imaging_times[(t_i - 1)] - offset
182		}
183	3x	startNonOffset <- if (t_i == 1) {
184	3x	NA
185		} else {
186	2x	imaging_times[(t_i - 1)]
187		}
188	3x	end <- imaging_times[t_i] - offset
189	3x	endNonOffset <- imaging_times[t_i]
190
191	3x	if (!is.na(start)) {
192	2x	w_i_t <- w_i[w_i[[time2]] > start & w_i[[time2]] < end, ]
193	2x	total_water_i <- max(c(sum(w_i_t[[waterCol]]), 1))
194	2x	pheno_iter <- max(df_i[df_i[[time1]] == endNonOffset, get(pheno)], na.rm = TRUE)
195		} else {
196	1x	total_water_i <- NA
197	1x	pheno_iter <- NA
198		}
199
200	3x	row <- data.frame(
201	3x	total_water = total_water_i,
202	3x	pheno_iter = pheno_iter,
203	3x	start = startNonOffset,
204	3x	end = endNonOffset,
205	3x	timeLengthSeconds = as.numeric(end) - as.numeric(start),
206	3x	offset = offset
207		)
208	3x	row$pWUE <- row$pheno_iter / row$total_water
209	3x	return(row)
210		}))
211	1x	iter_out <- cbind(df_i, wue_i)
212	1x	return(iter_out)
213		}))
214	1x	return(out)
215		}

1		#' Combine Draws From brms Models
2		#'
3		#' @description Helper function for binding draws from several \code{brms} models to make a data.frame
4		#' for use with \code{brms::hypothesis()}. This will also check that the draws are comparable using
5		#' basic model metrics.
6		#'
7		#' @param ... Some number of brmsfit objects and/or dataframes of draws
8		#' (should generally be the same type of model fit to different data)
9		#' @param message Logical, should messages about possible problems be printed? Default is TRUE.
10		#' This will warn if models may not have converged, if there are different numbers of draws in
11		#' the objects, or if models have different formulations.
12		#' @keywords brms
13		#' @importFrom methods is
14		#' @examples
15		#' # note that this example will fit several bayesian models and may run for several minutes.
16		#' \donttest{
17		#' simdf <- growthSim("logistic",
18		#' n = 20, t = 25,
19		#' params = list(
20		#' "A" = c(200, 160, 220, 200, 140, 300),
21		#' "B" = c(13, 11, 10, 9, 16, 12),
22		#' "C" = c(3, 3.5, 3.2, 2.8, 3.3, 2.5)
23		#' )
24		#' )
25		#' ss_ab <- growthSS(
26		#' model = "logistic", form = y ~ time \| id / group,
27		#' sigma = "logistic", df = simdf[simdf$group %in% c("a", "b"), ],
28		#' start = list(
29		#' "A" = 130, "B" = 12, "C" = 3,
30		#' "sigmaA" = 15, "sigmaB" = 10, "sigmaC" = 3
31		#' ), type = "brms"
32		#' )
33		#'
34		#' ss_cd <- growthSS(
35		#' model = "logistic", form = y ~ time \| id / group,
36		#' sigma = "logistic", df = simdf[simdf$group %in% c("c", "d"), ],
37		#' start = list(
38		#' "A" = 130, "B" = 12, "C" = 3,
39		#' "sigmaA" = 15, "sigmaB" = 10, "sigmaC" = 3
40		#' ), type = "brms"
41		#' )
42		#'
43		#' ss_ef <- growthSS(
44		#' model = "logistic", form = y ~ time \| id / group,
45		#' sigma = "logistic", df = simdf[simdf$group %in% c("e", "f"), ],
46		#' start = list(
47		#' "A" = 130, "B" = 12, "C" = 3,
48		#' "sigmaA" = 15, "sigmaB" = 10, "sigmaC" = 3
49		#' ), type = "brms"
50		#' )
51		#' ss_ef2 <- growthSS(
52		#' model = "gompertz", form = y ~ time \| id / group,
53		#' sigma = "logistic", df = simdf[simdf$group %in% c("e", "f"), ],
54		#' start = list(
55		#' "A" = 130, "B" = 12, "C" = 3,
56		#' "sigmaA" = 15, "sigmaB" = 10, "sigmaC" = 3
57		#' ), type = "brms"
58		#' )
59		#'
60		#'
61		#' fit_ab <- fitGrowth(ss_ab, chains = 1, cores = 1, iter = 1000)
62		#' fit_ab2 <- fitGrowth(ss_ab, chains = 1, cores = 1, iter = 1200)
63		#' fit_cd <- fitGrowth(ss_cd, chains = 1, cores = 1, iter = 1000)
64		#' fit_ef <- fitGrowth(ss_ef, chains = 1, cores = 1, iter = 1000)
65		#' fit_ef2 <- fitGrowth(ss_ef2, chains = 1, cores = 1, iter = 1000)
66		#'
67		#' x <- combineDraws(fit_ab, fit_cd, fit_ef)
68		#' draws_ef <- as.data.frame(fit_ef)
69		#' draws_ef <- draws_ef[, grepl("^b_", colnames(draws_ef))]
70		#' x2 <- combineDraws(fit_ab2, fit_cd, draws_ef)
71		#' x3 <- combineDraws(fit_ab, fit_cd, fit_ef2)
72		#' }
73		#'
74		#' @return Returns a dataframe of posterior draws.
75		#' @export
76
77
78
79
80		combineDraws <- function(..., message = TRUE) {
81	!	objects <- list(...)
82	!	if (!all(unlist(lapply(objects, function(m) {
83	!	methods::is(m, "brmsfit") \| methods::is(m, "data.frame")
84		})))) {
85	!	stop("Only brmsfit objects and data frames are accepted")
86		}
87
88	!	obj_names <- sapply(substitute(list(...)), deparse)[-1]
89	!	models <- objects[unlist(lapply(objects, function(m) {
90	!	methods::is(m, "brmsfit")
91		}))]
92	!	model_names <- obj_names[unlist(lapply(objects, function(m) {
93	!	methods::is(m, "brmsfit")
94		}))]
95	!	supplied_draw_dfs <- objects[unlist(lapply(objects, function(m) {
96	!	methods::is(m, "data.frame")
97		}))]
98	!	df_names <- obj_names[unlist(lapply(objects, function(m) {
99	!	methods::is(m, "data.frame")
100		}))]
101
102	!	max_fit_draws <- max(unlist(lapply(models, function(m) {
103	!	nrow(as.data.frame(m))
104		})))
105	!	max_nrow_supplied <- max(c(0, unlist(lapply(supplied_draw_dfs, nrow))))
106	!	limit_size <- max(c(max_fit_draws, max_nrow_supplied))
107
108		#* `check that formulae are the same`
109	!	if (message) {
110	!	formulae <- unlist(lapply(models, function(m) {
111	!	x <- as.character(m$formula$formula)
112	!	form <- paste0(x[2], x[1], x[3])
113	!	return(form)
114		}))
115	!	names(formulae) <- model_names
116	!	if (length(unique(formulae)) > 1) {
117	!	message("Some of these models have different growth formulas, consider if this is what you want.")
118	!	message(paste0(paste(names(formulae), formulae, sep = ": "), collapse = ", "))
119		}
120		}
121		#* `get and bind draws from models`
122	!	new_draws <- do.call(cbind, lapply(seq_along(models), function(i) {
123	!	m <- models[[i]]
124	!	mn <- model_names[[i]]
125	!	d <- as.data.frame(m)
126	!	draws <- d[, grepl("^b_", colnames(d))]
127	!	colnames(draws) <- gsub("^b", mn, colnames(draws))
128
129	!	if (message) {
130	!	rhats <- brms::rhat(m)
131	!	rhats <- rhats[grepl("^b_", names(rhats))]
132	!	if (any(rhats > 1.05)) {
133	!	message(paste0(
134	!	mn, " has Rhat values >1.05 for some model parameters.",
135	!	"See ?barg for possible improvements.\n"
136		))
137		}
138		}
139
140	!	if (nrow(draws) < limit_size) {
141	!	if (message) {
142	!	message(paste0(
143	!	mn, " has fewer than ", limit_size, " draws and will be padded with ",
144	!	limit_size - nrow(draws), " NAs\n"
145		))
146		}
147	!	draws[(nrow(draws) + 1):limit_size, ] <- NA
148	!	draws
149		}
150	!	draws
151		}))
152		#* `bind any other dataframes of draws`
153	!	if (length(supplied_draw_dfs) > 0) {
154	!	supplied_draw_dfs <- lapply(seq_along(supplied_draw_dfs), function(i) {
155	!	df <- supplied_draw_dfs[[i]]
156	!	dn <- df_names[[i]]
157	!	if (nrow(df) < limit_size) {
158	!	if (message) {
159	!	message(paste0(
160	!	dn, " has fewer than ", limit_size, " draws and will be padded with ",
161	!	limit_size - nrow(df), " NAs\n"
162		))
163		}
164	!	df[(nrow(df) + 1):limit_size, ] <- NA
165		}
166	!	df
167		})
168	!	new_draws <- do.call(cbind, args = list(supplied_draw_dfs, new_draws))
169		}
170	!	new_draws
171		}

1		#' Function to run a PCA, plot and optionally return the data with PCA coordinates and pca object
2		#'
3		#' @param df Dataframe to ordinate
4		#' @param cols columns to reduce dimensions of. Can be specified with names or positions.
5		#' If this is length of 1 then it is treated as regex pattern to match
6		#' the column names that should be used.
7		#' @param color column name(s) used to color points in the pca plot.
8		#' @param facet Optional column or vector to facet plots on.
9		#' @param returnData Logical, should data be returned?
10		#' @param ncp Optional, number of principal components to return attached
11		#' to dataframe if data is returned. Defaults to all.
12		#' @keywords pca
13		#' @details If data is returned then it will contain the coordinates from the
14		#' PCA and will not contain the columns that were reduced.
15		#'
16		#' @import ggplot2
17		#' @import FactoMineR
18		#' @importFrom stats as.formula
19		#' @return A ggplot or list with a ggplot, a dataframe with the data and PCs, and the factominer
20		#' PCA object as elements.
21		#' @examples
22		#'
23		#' dists <- list(
24		#' rlnorm = list(meanlog = log(40), sdlog = 0.5),
25		#' rnorm = list(mean = 60, sd = 10)
26		#' )
27		#' mv <- mvSim(
28		#' dists = dists, n_samples = 100, counts = 1000,
29		#' min_bin = 1, max_bin = 180, wide = TRUE
30		#' )
31		#' mv$otherGroup <- sample(c("a", "b"), size = nrow(mv), replace = TRUE)
32		#' pcadf(mv, cols = "sim_", returnData = TRUE)
33		#' pcadf(mv, cols = 2:181, color = c("group", "otherGroup"), returnData = FALSE)
34		#'
35		#' @export
36
37		pcadf <- function(df = NULL, cols = NULL, color = NULL,
38		facet = NULL, returnData = TRUE, ncp = NULL) {
39	3x	if (is.character(cols) && length(cols) == 1) {
40	2x	cols <- which(grepl(cols, colnames(df)))
41		}
42	3x	if (!is.null(color) && length(color) > 1) {
43	1x	df[[paste(color, collapse = ".")]] <- interaction(df[, color])
44	1x	color <- paste(color, collapse = ".")
45		}
46	3x	if (is.null(ncp)) {
47	3x	ncp <- min(dim(df[, cols])) - 1
48		}
49	3x	pca <- FactoMineR::PCA(df[, cols], ncp = ncp, graph = FALSE)
50	3x	pc1Var <- round(pca$eig[1, 2], 3)
51	3x	pc2Var <- round(pca$eig[2, 2], 3)
52	3x	coords <- as.data.frame(pca$ind)
53	3x	coords <- coords[, grepl("coord", colnames(coords))]
54	3x	colnames(coords) <- gsub("coord.Dim.", "pc", colnames(coords))
55	3x	if (!is.numeric(cols)) {
56	!	cols <- which(colnames(df) %in% cols)
57		}
58	3x	pca.df <- cbind(as.data.frame(df[, -cols]), coords)
59	3x	colnames(pca.df)[1:(length(colnames(df)) - length(cols))] <- colnames(df)[-cols]
60	3x	facetLayer <- NULL
61	3x	if (!is.null(facet)) {
62	!	facetLayer <- ggplot2::facet_wrap(as.formula(paste0("~", paste(facet, collapse = "+"))))
63		}
64
65	3x	if (is.null(color)) {
66	1x	pca.df$dummyVariableForColor <- 1
67	1x	color <- "dummyVariableForColor"
68		}
69
70	3x	plots <- .pcaGeneralPlot(pca.df, color, facetLayer, pc1Var, pc2Var)
71
72	3x	if (returnData) {
73	1x	return(list("data" = pca.df, "pca" = pca, "plot" = plots))
74		} else {
75	2x	return(plots)
76		}
77		}
78
79		#' general pca plotting
80		#' @keywords internal
81		#' @noRd
82
83		.pcaGeneralPlot <- function(pca.df, color, facetLayer, pc1Var, pc2Var) {
84	3x	plots <- ggplot2::ggplot(pca.df, ggplot2::aes(
85	3x	x = .data$pc1,
86	3x	y = .data$pc2, color = .data[[color]]
87		)) +
88	3x	ggplot2::geom_point() +
89	3x	ggplot2::labs(x = paste0("PC 1 (", pc1Var, "%)"), y = paste0("PC 2 (", pc2Var, "%)")) +
90	3x	pcv_theme()
91	3x	if (color == "dummyVariableForColor") {
92	1x	plots <- plots + ggplot2::theme(legend.position = "none")
93		}
94	3x	plots <- plots + facetLayer
95	3x	return(plots)
96		}